From 49b42208e0f1046bdd1e7ea945528947492ddde4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Wed, 16 Oct 2024 21:37:59 +0100 Subject: [PATCH 01/97] Initial class, interface, and enum separation --- src/generators/cpp/cppAst.ml | 9 +++++- src/generators/gencpp.ml | 55 +++++++++++++++++++++++++----------- 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 9b40716bf34..84399c3246b 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -155,4 +155,11 @@ and tcpp_expr_expr = | CppCastObjC of tcppexpr * tclass | CppCastObjCBlock of tcppexpr * tcpp list * tcpp | CppCastProtocol of tcppexpr * tclass - | CppCastNative of tcppexpr \ No newline at end of file + | CppCastNative of tcppexpr + +and tcpp_decl = + | ManagedClass of tclass + | NativeClass of tclass + | ManagedInterface of tclass + | NativeInterface of tclass + | Enum of tenum \ No newline at end of file diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 3c06e600b17..a5cf4f6e080 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -223,12 +223,21 @@ let generate_source ctx = 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 = (Common.defined common_ctx Define.Scriptable) in let existingIds = Hashtbl.create 0 in - List.iter (fun object_def -> + (* let checker object_def = + match object_def with + | TClassDecl class_def when is_extern_class class_def -> + None + | TClassDecl class_def when is_internal_class class_def.cl_path -> + None + | TClassDecl class_def -> + None + | o -> None in *) + + let mapped = List.filter_map (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 (Common.defined common_ctx Define.Objc) then match object_def with @@ -241,12 +250,15 @@ let generate_source ctx = let source = get_meta_string_path class_def.cl_meta Meta.SourceFile in if (source<>"") then extern_src := source :: !extern_src; + + None | 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 + if (is_internal || (Meta.has Meta.Macro class_def.cl_meta)) then begin + ( if (debug>=4) then print_endline (" internal class " ^ name )); + None + end else begin let rec makeId class_name seed = let id = gen_hash32 seed class_name in (* reserve first 100 ids for runtime *) @@ -265,18 +277,20 @@ let generate_source ctx = 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; + + Some (ManagedClass class_def) end - | TEnumDecl enum_def when has_enum_flag enum_def EnExtern -> () + | TEnumDecl enum_def when has_enum_flag enum_def EnExtern -> None | 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 + if (is_internal) then begin + (if (debug>1) then print_endline (" internal enum " ^ name )); + None + end else begin let rec makeId enum_name seed = let id = gen_hash32 seed enum_name in (* reserve first 100 ids for runtime *) @@ -291,16 +305,25 @@ let generate_source ctx = 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; + + Some (Enum enum_def) end - | TTypeDecl _ | TAbstractDecl _ -> (* already done *) () + | TTypeDecl _ | TAbstractDecl _ -> (* already done *) None ); - ) common_ctx.types; - - List.iter (fun job -> job () ) !jobs; - + ) common_ctx.types in + + let jobs = List.map (fun tcpp_type -> match tcpp_type with + | ManagedClass class_def + | NativeClass class_def + | ManagedInterface class_def + | NativeInterface class_def -> + (fun () -> generate_class_files ctx class_def) + | Enum enum_def -> + (fun () -> CppGenEnum.generate ctx enum_def)) mapped in + + List.iter (fun job -> job () ) jobs; (match common_ctx.main.main_expr with | None -> CppGen.generate_dummy_main common_ctx From 59e730cdf6a6b84a6edd5093f23c8e5be76af75d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Wed, 16 Oct 2024 23:17:30 +0100 Subject: [PATCH 02/97] fold init stuff --- src/generators/gencpp.ml | 189 +++++++++++++++++++-------------------- 1 file changed, 90 insertions(+), 99 deletions(-) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a5cf4f6e080..87f000afd41 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -210,120 +210,111 @@ let generate_class_files 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; +} + 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 build_xml = ref "" in let scriptable = (Common.defined common_ctx Define.Scriptable) in let existingIds = Hashtbl.create 0 in - (* let checker object_def = - match object_def with - | TClassDecl class_def when is_extern_class class_def -> - None - | TClassDecl class_def when is_internal_class class_def.cl_path -> - None - | TClassDecl class_def -> - None - | o -> None in *) - - let mapped = List.filter_map (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 (Common.defined common_ctx Define.Objc) then match object_def 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 + (* (if not (Common.defined common_ctx Define.Objc) then match object_def 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 + | _ -> ()); *) + + let initial = { + extern_src = []; + build_xml = ""; + boot_classes = []; + init_classes = []; + nonboot_classes = []; + boot_enums = []; + exe_classes = []; + decls = []; + } in + + let rec make_id 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 + make_id class_name (seed+100) + else begin + Hashtbl.add existingIds id true; + Hashtbl.add ctx.ctx_type_ids class_name id; + end in + + let folder acc cur = + 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 -> source :: 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 - None | 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 begin - ( if (debug>=4) then print_endline (" internal class " ^ name )); - None - end 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; - 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; - - Some (ManagedClass class_def) - end - | TEnumDecl enum_def when has_enum_flag enum_def EnExtern -> None + make_id (class_text class_def.cl_path) 0; + + let acc_decls = (ManagedClass class_def) :: 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) super_deps 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 } + + | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> + acc + | 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 begin - (if (debug>1) then print_endline (" internal enum " ^ name )); - None - end 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; - 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; - - Some (Enum enum_def) - end - | TTypeDecl _ | TAbstractDecl _ -> (* already done *) None - ); - ) common_ctx.types in - - let jobs = List.map (fun tcpp_type -> match tcpp_type with + make_id (class_text enum_def.e_path) 0; + + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false true false in + let acc_decls = (Enum enum_def) :: 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 } + | _ -> + acc + in + let srcctx = List.fold_left folder initial common_ctx.types in + + List.iter (fun tcpp_type -> + match tcpp_type with | ManagedClass class_def | NativeClass class_def | ManagedInterface class_def | NativeInterface class_def -> - (fun () -> generate_class_files ctx class_def) + generate_class_files ctx class_def | Enum enum_def -> - (fun () -> CppGenEnum.generate ctx enum_def)) mapped in - - List.iter (fun job -> job () ) jobs; + CppGenEnum.generate ctx enum_def) srcctx.decls; (match common_ctx.main.main_expr with | None -> CppGen.generate_dummy_main common_ctx @@ -336,7 +327,7 @@ let generate_source ctx = CppGen.generate_main 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; CppGen.generate_files common_ctx ctx.ctx_file_info; @@ -376,7 +367,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 -> @@ -392,7 +383,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 (Common.defined common_ctx Define.NoCompilation) ) then begin let t = Timer.timer ["generate";"cpp";"native compilation"] in From 354da10ed7780273beb1fa21945a4014007b4ef1 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 17:22:29 +0100 Subject: [PATCH 03/97] Move interface header generation into its own module --- .../cpp/gen/cppGenInterfaceHeader.ml | 275 ++++++++++++++++++ src/generators/gencpp.ml | 32 +- 2 files changed, 293 insertions(+), 14 deletions(-) create mode 100644 src/generators/cpp/gen/cppGenInterfaceHeader.ml diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml new file mode 100644 index 00000000000..4d69f00e58a --- /dev/null +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -0,0 +1,275 @@ +open Ast +open Type +open Error +open Common +open Globals +open CppStrings +open CppExprUtils +open CppTypeUtils +open CppAst +open CppAstTools +open CppSourceWriter +open CppContext +open CppGen + +let gen_member_def ctx class_def is_static field = + match (follow field.cf_type, field.cf_kind) with + | _, Method MethDynamic -> () + | TFun (args, return_type), Method _ -> + 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 + let gen_args = print_tfun_arg_list true in + + if is_static || nativeGen then ( + output ((if is_static then "\t\t" else "\t\tvirtual ") ^ type_to_string return_type); + output (" " ^ remap_name ^ "( "); + output (gen_args args); + output (if is_static then ");\n" else ")=0;\n"); + if reflective class_def field then + if Common.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") + | _ -> () + +let generate_native_interface base_ctx interface_def = + let common_ctx = base_ctx.ctx_common in + let class_path = interface_def.cl_path in + let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in + let class_name = class_name interface_def in + + let debug = + if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then + 0 + else + 1 + in + + let parent, super = + match interface_def.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 debug 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; + + 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); + + (* 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 header_referenced, header_flags = + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" super_deps (Hashtbl.create 0) 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 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; + + begin_namespace output_h class_path; + output_h "\n\n"; + output_h (get_class_code interface_def Meta.HeaderNamespaceCode); + + let attribs = match Common.defined common_ctx Define.DllExport with + | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" + | false -> "HXCPP_CLASS_ATTRIBUTES" in + + output_h ("class " ^ attribs ^ " " ^ class_name ^ " : public " ^ parent); + + interface_def.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 " ^ class_name ^ " OBJ_;\n"); + + CppGen.generate_native_constructor ctx output_h interface_def true; + + if has_boot_field interface_def then output_h "\t\tstatic void __boot();\n"; + + match interface_def.cl_array_access with + | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") + | _ -> (); + + interface_def.cl_ordered_statics + |> List.filter should_implement_field + |> List.iter (gen_member_def ctx interface_def true); + + interface_def + |> all_virtual_functions + |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def false field); + + match get_meta_string interface_def.cl_meta Meta.ObjcProtocol with + | Some protocol -> + output_h ("\t\tstatic id<" ^ protocol ^ "> _hx_toProtocol(Dynamic inImplementation);\n") + | None -> + (); + + output_h (get_class_code interface_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_interface base_ctx interface_def = + let common_ctx = base_ctx.ctx_common in + let class_path = interface_def.cl_path in + let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in + let class_name = class_name interface_def in + + (*let cpp_file = new_cpp_file common_ctx.file class_path in*) + let debug = + if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then + 0 + else + 1 + in + + let parent, super = + match interface_def.cl_super with + | Some (klass, params) -> + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in + ( name, name ) + | 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 debug 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; + + 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); + + (* 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 header_referenced, header_flags = + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" super_deps (Hashtbl.create 0) 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 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; + + begin_namespace output_h class_path; + output_h "\n\n"; + output_h (get_class_code interface_def Meta.HeaderNamespaceCode); + + let extern_class = Common.defined common_ctx Define.DllExport in + let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" in + + output_h ("class " ^ attribs ^ " " ^ class_name ^ " {\n"); + output_h "\tpublic:\n"; + output_h ("\t\ttypedef " ^ super ^ " super;\n"); + output_h "\t\tHX_DO_INTERFACE_RTTI;\n\n"; + + if has_boot_field interface_def then output_h "\t\tstatic void __boot();\n"; + + match interface_def.cl_array_access with + | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") + | _ -> (); + + interface_def.cl_ordered_statics + |> List.filter should_implement_field + |> List.iter (gen_member_def ctx interface_def true); + + interface_def + |> all_virtual_functions + |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def false field); + + match get_meta_string interface_def.cl_meta Meta.ObjcProtocol with + | Some protocol -> + output_h ("\t\tstatic id<" ^ protocol ^ "> _hx_toProtocol(Dynamic inImplementation);\n") + | None -> + (); + + output_h (get_class_code interface_def Meta.HeaderClassCode); + 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/gencpp.ml b/src/generators/gencpp.ml index 87f000afd41..a02e9f74890 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -199,14 +199,6 @@ let is_assign_op op = | OpAssign | 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 *) @@ -274,7 +266,13 @@ let generate_source ctx = | TClassDecl class_def -> make_id (class_text class_def.cl_path) 0; - let acc_decls = (ManagedClass class_def) :: acc.decls in + let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in + let decl = + match has_class_flag class_def CInterface with + | true -> if native_gen then (NativeInterface class_def) else (ManagedInterface class_def) + | false -> if native_gen then (NativeClass class_def) else (ManagedClass class_def) 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 @@ -308,11 +306,17 @@ let generate_source ctx = List.iter (fun tcpp_type -> match tcpp_type with - | ManagedClass class_def - | NativeClass class_def - | ManagedInterface class_def - | NativeInterface class_def -> - generate_class_files ctx class_def + | ManagedClass class_def -> + CppGenClassHeader.generate ctx class_def; + CppGenClassImplementation.generate ctx class_def; + | NativeClass class_def -> + CppGenClassHeader.generate ctx class_def; + CppGenClassImplementation.generate ctx class_def; + | ManagedInterface interface_def -> + CppGenInterfaceHeader.generate_managed_interface ctx interface_def; + CppGenClassImplementation.generate ctx interface_def; + | NativeInterface interface_def -> + CppGenInterfaceHeader.generate_native_interface ctx interface_def | Enum enum_def -> CppGenEnum.generate ctx enum_def) srcctx.decls; From d9bfebd67c5df3ab0495f5463c9db2aba37e32ab Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 17:48:04 +0100 Subject: [PATCH 04/97] reduce some duplication --- .../cpp/gen/cppGenInterfaceHeader.ml | 202 +++++++----------- 1 file changed, 76 insertions(+), 126 deletions(-) diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 4d69f00e58a..fbe6b5fc2fd 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -12,6 +12,16 @@ open CppSourceWriter open CppContext open CppGen +let calculate_debug_level interface_def base_ctx = + if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then + 0 + else + 1 + +let attribs common_ctx = match Common.defined common_ctx Define.DllExport with + | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" + | false -> "HXCPP_CLASS_ATTRIBUTES" + let gen_member_def ctx class_def is_static field = match (follow field.cf_type, field.cf_kind) with | _, Method MethDynamic -> () @@ -54,41 +64,13 @@ let gen_member_def ctx class_def is_static field = 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") + ("\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") | _ -> () -let generate_native_interface base_ctx interface_def = - let common_ctx = base_ctx.ctx_common in - let class_path = interface_def.cl_path in - let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in - let class_name = class_name interface_def in - - let debug = - if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then - 0 - else - 1 - in - - let parent, super = - match interface_def.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 debug 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; - +let gen_includes h_file interface_def = let add_class_includes cls = match get_all_meta_string_path cls.cl_meta Meta.Include with | [] -> @@ -104,9 +86,11 @@ let generate_native_interface base_ctx interface_def = (* And any interfaces ... *) interface_def.cl_implements |> real_interfaces - |> List.iter (fun (cls, _) -> add_class_includes cls); + |> List.iter (fun (cls, _) -> add_class_includes cls) +let gen_forward_decls h_file interface_def ctx common_ctx = (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) + let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let super_deps = create_super_dependencies common_ctx in let header_referenced, header_flags = CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" super_deps (Hashtbl.create 0) true false scriptable @@ -114,34 +98,16 @@ let generate_native_interface base_ctx interface_def = List.iter2 (fun r f -> gen_forward_decl h_file r f) - header_referenced header_flags; - output_h "\n"; + 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; - - begin_namespace output_h class_path; - output_h "\n\n"; - output_h (get_class_code interface_def Meta.HeaderNamespaceCode); - - let attribs = match Common.defined common_ctx Define.DllExport with - | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" - | false -> "HXCPP_CLASS_ATTRIBUTES" in - - output_h ("class " ^ attribs ^ " " ^ class_name ^ " : public " ^ parent); - - interface_def.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 " ^ class_name ^ " OBJ_;\n"); - - CppGen.generate_native_constructor ctx output_h interface_def true; + List.iter printer includes +let gen_body interface_def ctx output_h = if has_boot_field interface_def then output_h "\t\tstatic void __boot();\n"; match interface_def.cl_array_access with @@ -162,11 +128,55 @@ let generate_native_interface base_ctx interface_def = | None -> (); - output_h (get_class_code interface_def Meta.HeaderClassCode); + output_h (get_class_code interface_def Meta.HeaderClassCode) + +let generate_native_interface base_ctx interface_def = + let common_ctx = base_ctx.ctx_common in + let class_path = interface_def.cl_path in + let class_name = class_name interface_def in + + let parent, super = + match interface_def.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 debug = calculate_debug_level interface_def base_ctx in + let ctx = file_context base_ctx h_file debug 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 interface_def; + gen_forward_decls h_file interface_def ctx common_ctx; + gen_header_includes interface_def output_h; + + begin_namespace output_h class_path; + output_h "\n\n"; + output_h (get_class_code interface_def Meta.HeaderNamespaceCode); + + output_h ("class " ^ (attribs common_ctx) ^ " " ^ class_name ^ " : public " ^ parent); + + interface_def.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 " ^ class_name ^ " OBJ_;\n"); + + CppGen.generate_native_constructor ctx output_h interface_def true; + + gen_body interface_def ctx output_h; + output_h "};\n\n"; end_namespace output_h class_path; - end_header_file output_h def_string; h_file#close @@ -174,17 +184,8 @@ let generate_native_interface base_ctx interface_def = let generate_managed_interface base_ctx interface_def = let common_ctx = base_ctx.ctx_common in let class_path = interface_def.cl_path in - let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let class_name = class_name interface_def in - (*let cpp_file = new_cpp_file common_ctx.file class_path in*) - let debug = - if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then - 0 - else - 1 - in - let parent, super = match interface_def.cl_super with | Some (klass, params) -> @@ -194,82 +195,31 @@ let generate_managed_interface base_ctx interface_def = ("", "::hx::Object") in let h_file = new_header_file common_ctx common_ctx.file class_path in + let debug = calculate_debug_level interface_def base_ctx in let ctx = file_context base_ctx h_file debug 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; - 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); - - (* 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 header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" super_deps (Hashtbl.create 0) 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 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; + gen_includes h_file interface_def; + gen_forward_decls h_file interface_def ctx common_ctx; + gen_header_includes interface_def output_h; begin_namespace output_h class_path; output_h "\n\n"; output_h (get_class_code interface_def Meta.HeaderNamespaceCode); - let extern_class = Common.defined common_ctx Define.DllExport in - let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" in - - output_h ("class " ^ attribs ^ " " ^ class_name ^ " {\n"); + output_h ("class " ^ (attribs common_ctx) ^ " " ^ class_name ^ " {\n"); output_h "\tpublic:\n"; output_h ("\t\ttypedef " ^ super ^ " super;\n"); output_h "\t\tHX_DO_INTERFACE_RTTI;\n\n"; - if has_boot_field interface_def then output_h "\t\tstatic void __boot();\n"; - - match interface_def.cl_array_access with - | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") - | _ -> (); - - interface_def.cl_ordered_statics - |> List.filter should_implement_field - |> List.iter (gen_member_def ctx interface_def true); - - interface_def - |> all_virtual_functions - |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def false field); - - match get_meta_string interface_def.cl_meta Meta.ObjcProtocol with - | Some protocol -> - output_h ("\t\tstatic id<" ^ protocol ^ "> _hx_toProtocol(Dynamic inImplementation);\n") - | None -> - (); - - output_h (get_class_code interface_def Meta.HeaderClassCode); + gen_body interface_def ctx output_h; + 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 From 249688d0aa3016b78e81a4a8f3fa876639e99b73 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 21:09:56 +0100 Subject: [PATCH 05/97] managed interface implementation gen in its own module --- .../cpp/gen/cppGenInterfaceImplementation.ml | 321 ++++++++++++++++++ src/generators/gencpp.ml | 2 +- 2 files changed, 322 insertions(+), 1 deletion(-) create mode 100644 src/generators/cpp/gen/cppGenInterfaceImplementation.ml diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml new file mode 100644 index 00000000000..c16f03ac9c2 --- /dev/null +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -0,0 +1,321 @@ +open Ast +open Type +open Error +open Common +open Globals +open CppStrings +open CppExprUtils +open CppTypeUtils +open CppAst +open CppAstTools +open CppSourceWriter +open CppContext +open CppGen + +let gen_field_init ctx class_def field = + let dot_name = join_class_path class_def.cl_path "." in + let remap_name = keyword_remap field.cf_name in + + match field.cf_expr with + | Some expr -> + let var_name = + match remap_name with + | "__meta__" -> "__mClass->__meta__" + | "__rtti" -> "__mClass->__rtti__" + | _ -> remap_name + in + + gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr + | _ -> () + +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" 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" + | _ -> () + in + List.iter dump_delegate class_def.cl_ordered_fields; + + output "@end\n\n" + +let generate_managed_interface baseCtx class_def = + let common_ctx = baseCtx.ctx_common 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 ctx = cpp_ctx in + let output_cpp = cpp_file#write in + let strq = strq ctx.ctx_common in + let scriptable = Common.defined common_ctx Define.Scriptable && not class_def.cl_private 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 + in + 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 = class_name class_def in + + output_cpp "\n"; + + (* cl_interface *) + let implemented_instance_fields = List.filter should_implement_field class_def.cl_ordered_fields in + let reflective_members = List.filter (reflective class_def) implemented_instance_fields in + let sMemberFields = + match reflective_members with + | [] -> "0 /* sMemberFields */" + | _ -> + let memberFields = class_name ^ "_sMemberFields" in + let dump_field_name field = output_cpp ("\t" ^ strq field.cf_name ^ ",\n") in + output_cpp ("static ::String " ^ memberFields ^ "[] = {\n"); + List.iter dump_field_name reflective_members; + output_cpp "\t::String(null()) };\n\n"; + memberFields + in + + if scriptable then ( + let dump_script_field idx (field, f_args, return_t) = + let args = print_tfun_arg_list true 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 + + output_cpp ("\t" ^ return_type ^ " " ^ 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 ^ "(" + ^ 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"; + in + + let sctipt_name = class_name ^ "__scriptable" in + + output_cpp ("class " ^ sctipt_name ^ " : public ::hx::Object {\n"); + output_cpp "public:\n"; + + let list_iteri func in_list = + let idx = ref 0 in + List.iter + (fun elem -> + func !idx elem; + idx := !idx + 1) + in_list + in + + list_iteri dump_script_field (all_virtual_functions class_def); + output_cpp "};\n\n"; + + let generate_script_function field scriptName callName = + match follow field.cf_type with + | TFun (args, return_type) when not (is_data_member field) -> + output_cpp ("\nstatic void CPPIA_CALL " ^ scriptName ^ "(::hx::CppiaCtx *ctx) {\n"); + let ret = + match cpp_type_of return_type with + | TCppScalar "bool" -> "b" + | _ -> CppCppia.script_signature return_type false in + if ret <> "v" then + output_cpp ("ctx->return" ^ CppCppia.script_type return_type false ^ "("); + + let signature = + output_cpp (class_name ^ "::" ^ callName ^ "(ctx->getThis()" ^ if List.length 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*)") args in + output_cpp ")"; + signature + in + + if ret <> "v" then output_cpp ")"; + output_cpp ";\n}\n"; + signature + | _ -> "" + in + + let sigs = Hashtbl.create 0 in + let new_sctipt_functions = all_virtual_functions class_def in + match new_sctipt_functions with + | [] -> + output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" + | _ -> + List.iter + (fun (f, _, _) -> + let s = generate_script_function f ("__s_" ^ f.cf_name) (keyword_remap f.cf_name) in + Hashtbl.add sigs f.cf_name s) + new_sctipt_functions; + + 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; + output_cpp " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n"; + + 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"); + + let class_name_text = join_class_path class_path "." in + + 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"; + output_cpp ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields ^ ");\n"); + output_cpp ("\t__mClass->mCanCast = ::hx::TIsInterface< (int)" ^ cpp_class_hash class_def ^ " >;\n"); + output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; + if scriptable then + 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"); + + List.iter + (gen_field_init ctx class_def) + (List.filter should_implement_field class_def.cl_ordered_statics); + + output_cpp "}\n\n"); + + end_namespace output_cpp class_path; + + if 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 \ No newline at end of file diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a02e9f74890..b36d54745fd 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -314,7 +314,7 @@ let generate_source ctx = CppGenClassImplementation.generate ctx class_def; | ManagedInterface interface_def -> CppGenInterfaceHeader.generate_managed_interface ctx interface_def; - CppGenClassImplementation.generate ctx interface_def; + CppGenInterfaceImplementation.generate_managed_interface ctx interface_def; | NativeInterface interface_def -> CppGenInterfaceHeader.generate_native_interface ctx interface_def | Enum enum_def -> From 93df3282411f06658698891ed0148bd4b9f0b6fc Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 21:32:41 +0100 Subject: [PATCH 06/97] cache dependencies in the ctx --- src/generators/cpp/cppContext.ml | 6 +++++- src/generators/cpp/gen/cppGenClassHeader.ml | 6 ++---- .../cpp/gen/cppGenClassImplementation.ml | 9 +++------ src/generators/cpp/gen/cppGenEnum.ml | 3 +-- .../cpp/gen/cppGenInterfaceHeader.ml | 3 +-- .../cpp/gen/cppGenInterfaceImplementation.ml | 6 ++---- src/generators/gencpp.ml | 18 +++++++++--------- 7 files changed, 23 insertions(+), 28 deletions(-) diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index 6a45ca0895e..76bfe89c0f3 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -30,12 +30,14 @@ type context = { ctx_is_header : bool; ctx_interface_slot : (string, int) Hashtbl.t ref; ctx_interface_slot_count : int ref; + ctx_super_deps : (path, path list) Hashtbl.t; + ctx_constructor_deps : (path, tclass_field) Hashtbl.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 @@ -57,6 +59,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/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 8a12ebcc8fc..1be868c42f5 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -278,10 +278,9 @@ let generate baseCtx class_def = (* 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 header_referenced, header_flags = CppReferences.find_referenced_types_flags ctx (TClassDecl class_def) "*" - super_deps (Hashtbl.create 0) true false scriptable + ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable in List.iter2 (fun r f -> gen_forward_decl h_file r f) @@ -351,8 +350,7 @@ let generate baseCtx class_def = ^ "," ^ 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) + can_inline_constructor baseCtx class_def ctx.ctx_super_deps ctx.ctx_constructor_deps then ( output_h "\n"; CppGen.generate_constructor ctx diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 009b237f43e..2f820f304bd 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -316,11 +316,9 @@ let generate baseCtx class_def = 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; @@ -585,8 +583,7 @@ let generate baseCtx class_def = output_cpp "}\n"); let inline_constructor = - can_inline_constructor baseCtx class_def super_deps - (create_constructor_dependencies common_ctx) + can_inline_constructor baseCtx class_def ctx.ctx_super_deps ctx.ctx_constructor_deps in if (not (has_class_flag class_def CInterface)) diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 287ab5d5558..808fc6e39a4 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -33,8 +33,7 @@ let generate baseCtx enum_def = 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 enum_def) "*" ctx.ctx_super_deps (Hashtbl.create 0) false false false in List.iter (add_include cpp_file) referenced; begin_namespace output_cpp class_path; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index fbe6b5fc2fd..216eb7e0864 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -91,9 +91,8 @@ let gen_includes h_file interface_def = let gen_forward_decls h_file interface_def ctx common_ctx = (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in - let super_deps = create_super_dependencies common_ctx in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" super_deps (Hashtbl.create 0) true false scriptable + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable in List.iter2 diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index c16f03ac9c2..647eed0c244 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -125,11 +125,9 @@ let generate_managed_interface baseCtx class_def = 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; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index b36d54745fd..90c419b9e21 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -217,8 +217,6 @@ type gensrc_ctx = { let generate_source ctx = let common_ctx = ctx.ctx_common in make_base_directory common_ctx.file; - 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 scriptable = (Common.defined common_ctx Define.Scriptable) in let existingIds = Hashtbl.create 0 in @@ -281,7 +279,7 @@ let generate_source ctx = 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) super_deps constructor_deps false true scriptable in + 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 @@ -293,7 +291,7 @@ let generate_source ctx = | TEnumDecl enum_def -> make_id (class_text enum_def.e_path) 0; - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false true false in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps (Hashtbl.create 0) false true false in let acc_decls = (Enum enum_def) :: 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 @@ -327,8 +325,8 @@ 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 srcctx.boot_enums srcctx.boot_classes srcctx.nonboot_classes srcctx.init_classes; @@ -411,10 +409,12 @@ let generate_source ctx = let generate common_ctx = let debug_level = if (Common.defined common_ctx Define.NoDebug) then 0 else 1 in + let super_deps = CppGen.create_super_dependencies common_ctx in + let constructor_deps = CppGen.create_constructor_dependencies common_ctx in if (Common.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) (Hashtbl.create 0) 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 \ No newline at end of file From 36ddd73e520ac54486e701ee35b5c6469357ab64 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 21:41:46 +0100 Subject: [PATCH 07/97] move to gencpp with the other context data func --- src/generators/cpp/gen/cppGen.ml | 50 ++----------------- src/generators/cpp/gen/cppGenClassHeader.ml | 2 +- .../cpp/gen/cppGenClassImplementation.ml | 2 +- src/generators/gencpp.ml | 48 +++++++++++++++++- 4 files changed, 51 insertions(+), 51 deletions(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 2a07db66dde..d24ab60a635 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -408,38 +408,7 @@ let rec is_dynamic_accessor name acc field class_def = | 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 @@ -462,25 +431,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) + "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")) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 1be868c42f5..951df6c78dc 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -350,7 +350,7 @@ let generate baseCtx class_def = ^ "," ^ gcName ^ "); }\n"); if has_class_flag class_def CAbstract then output_h "\n" else if - can_inline_constructor baseCtx class_def ctx.ctx_super_deps ctx.ctx_constructor_deps + can_inline_constructor baseCtx class_def then ( output_h "\n"; CppGen.generate_constructor ctx diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 2f820f304bd..78c471dfb42 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -583,7 +583,7 @@ let generate baseCtx class_def = output_cpp "}\n"); let inline_constructor = - can_inline_constructor baseCtx class_def ctx.ctx_super_deps ctx.ctx_constructor_deps + can_inline_constructor baseCtx class_def in if (not (has_class_flag class_def CInterface)) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 90c419b9e21..55ba98a7db7 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -194,6 +194,50 @@ let create_member_types common_ctx = ) ) common_ctx.types; result +(* Builds inheritance tree, so header files can include parents defs. *) +let create_super_dependencies common_ctx = + let result = Hashtbl.create 0 in + 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 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 is_assign_op op = match op with | OpAssign @@ -409,8 +453,8 @@ let generate_source ctx = let generate common_ctx = let debug_level = if (Common.defined common_ctx Define.NoDebug) then 0 else 1 in - let super_deps = CppGen.create_super_dependencies common_ctx in - let constructor_deps = CppGen.create_constructor_dependencies common_ctx in + let super_deps = create_super_dependencies common_ctx in + let constructor_deps = create_constructor_dependencies common_ctx in if (Common.defined common_ctx Define.Cppia) then begin let ctx = new_context common_ctx debug_level (ref PMap.empty) (Hashtbl.create 0) super_deps constructor_deps in CppCppia.generate_cppia ctx From de409db163e4e161ec4ea585efea61c452fe391b Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 22:06:27 +0100 Subject: [PATCH 08/97] remove interface code from class gen modules --- src/generators/cpp/gen/cppGenClassHeader.ml | 354 +++++++----------- .../cpp/gen/cppGenClassImplementation.ml | 218 +++-------- 2 files changed, 192 insertions(+), 380 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 951df6c78dc..0cbe2cee5cf 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -12,198 +12,135 @@ open CppSourceWriter open CppContext open CppGen -let gen_member_def ctx class_def is_static is_interface field = +let gen_member_def ctx class_def is_static field = 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 Common.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"); + 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\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 = - Common.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 + ("\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 = + Common.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); - 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 *) + 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 + + 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 - | _ 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") - | _ -> ())) + | 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 *) + if (not nativeGen) then + match follow field.cf_type with + | 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 = - Common.defined common_ctx Define.Scriptable && not class_def.cl_private - in + let scriptable = Common.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 @@ -235,13 +172,7 @@ let generate baseCtx class_def = 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") + ( name, name ) | None when nativeGen -> ("", "") | None -> ("::hx::Object", "::hx::Object") in @@ -312,11 +243,7 @@ let generate baseCtx class_def = class_def.cl_implements) 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 ( + if super = "" then ( output_h ("class " ^ attribs ^ " " ^ class_name); dump_native_interfaces (); output_h "\n{\n\tpublic:\n") @@ -328,13 +255,16 @@ let generate baseCtx class_def = 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 - in - let classIdTxt = Printf.sprintf "0x%08lx" classId in + if (nativeGen) then + (* native interface *) + CppGen.generate_native_constructor ctx output_h class_def true + else ( + let classId = + try Hashtbl.find baseCtx.ctx_type_ids (class_text class_def.cl_path) + with Not_found -> Int32.zero + in + let classIdTxt = Printf.sprintf "0x%08lx" classId 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"); @@ -403,8 +333,7 @@ let generate baseCtx class_def = ^ " *>(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 + let needs_gc_funcs = (not nativeGen) && 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"); @@ -504,11 +433,7 @@ let generate baseCtx class_def = 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 *) ()); + ^ "; }\n\n")); if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; @@ -517,29 +442,12 @@ let generate baseCtx class_def = | _ -> ()); List.iter - (gen_member_def ctx class_def true (has_class_flag class_def CInterface)) + (gen_member_def ctx class_def true) (List.filter should_implement_field class_def.cl_ordered_statics); - 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 -> ()); + List.iter + (gen_member_def ctx class_def false) + (List.filter should_implement_field class_def.cl_ordered_fields); 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 78c471dfb42..92b8a4bdd78 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -349,7 +349,7 @@ let generate baseCtx class_def = implementations class_def in - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( + if (not nativeGen) then ( output_cpp ("void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")"); (match class_def.cl_constructor with @@ -585,11 +585,8 @@ let generate baseCtx class_def = let inline_constructor = can_inline_constructor baseCtx class_def 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 + if (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; @@ -601,7 +598,7 @@ let generate baseCtx class_def = in (* Initialise non-static variables *) - if (not (has_class_flag class_def CInterface)) && not nativeGen then ( + if (not nativeGen) then ( output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); List.iter (fun name -> @@ -986,9 +983,7 @@ let generate baseCtx class_def = 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 @@ -1003,11 +998,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 ^ "("); @@ -1041,10 +1033,7 @@ 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 @@ -1054,112 +1043,60 @@ let generate baseCtx class_def = 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"); - 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"); - List.iter - (fun (name, opt, t) -> - output_cpp - ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" - ^ keyword_remap name ^ ");\n")) - f_args; - output_cpp - ("\t\t" ^ ret ^ "__ctx->run" - ^ CppCppia.script_type return_t 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 = - Common.defined baseCtx.ctx_common Define.DynamicInterfaceClosures - in - if has_class_flag class_def CInterface && not dynamic_interface_closures - then + output_cpp ("\tif (" ^ vtable ^ ") {\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 - ("\tDynamic " ^ name - ^ "_dyn() { return mDelegate->__Field(HX_CSTRING(\"" ^ field.cf_name - ^ "\"), ::hx::paccNever); }\n\n")) - in + ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" + ^ keyword_remap name ^ ");\n")) + f_args; + output_cpp + ("\t\t" ^ ret ^ "__ctx->run" + ^ CppCppia.script_type return_t false + ^ "(" ^ vtable ^ ");\n"); + output_cpp ("\t} else " ^ ret); - let new_sctipt_functions = - if newInteface then all_virtual_functions class_def - else List.rev (current_virtual_functions_rev class_def []) + output_cpp + (class_name ^ "::" ^ name ^ "(" ^ String.concat "," names ^ ");"); + if return_type <> "void" then output_cpp "return null();"; + output_cpp "}\n"; in + + let new_sctipt_functions = 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")); + 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"); + output_cpp + (" HX_DEFINE_SCRIPTABLE(HX_ARR_LIST" + ^ string_of_int (List.length constructor_var_list) + ^ ")\n"); + output_cpp "\tHX_DEFINE_SCRIPTABLE_DYNAMIC;\n"; let list_iteri func in_list = let idx = ref 0 in @@ -1170,12 +1107,8 @@ let generate baseCtx class_def = in_list in - 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 + let not_toString (field, args, _) = field.cf_name <> "toString" in + let functions = List.filter not_toString (all_virtual_functions class_def) in list_iteri dump_script_field functions; output_cpp "};\n\n"; @@ -1218,9 +1151,10 @@ let generate baseCtx class_def = (" ::hx::ScriptNamedFunction(\"" ^ f.cf_name ^ "\",__s_" ^ f.cf_name ^ ",\"" ^ s ^ "\", " ^ isStaticFlag ^ " "); let superCall = - if isStaticFlag = "true" || has_class_flag class_def CInterface then + if isStaticFlag = "true" then "0" - else "__s_" ^ f.cf_name ^ "" + else + "__s_" ^ f.cf_name ^ "" in output_cpp ("HXCPP_CPPIA_SUPER_ARG(" ^ superCall ^ ")"); output_cpp " ),\n" @@ -1231,23 +1165,12 @@ let generate baseCtx class_def = " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n") 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")); + "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 ( + if (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 @@ -1368,23 +1291,4 @@ let generate baseCtx class_def = 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 \ No newline at end of file From ebaa770760f201ef8d37f16860a05947afa8e967 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 22:44:23 +0100 Subject: [PATCH 09/97] Use option for reference wildcard --- src/generators/cpp/gen/cppGen.ml | 2 +- src/generators/cpp/gen/cppGenClassHeader.ml | 2 +- src/generators/cpp/gen/cppGenEnum.ml | 2 +- src/generators/cpp/gen/cppGenInterfaceHeader.ml | 2 +- src/generators/cpp/gen/cppReferences.ml | 11 +++++++---- 5 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index d24ab60a635..9d48c3e699e 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -432,7 +432,7 @@ let can_inline_constructor base_ctx class_def = (* This is quite restrictive, since most classes are forward-declared *) let deps, _ = CppReferences.find_referenced_types_flags base_ctx (TClassDecl class_def) - "new" base_ctx.ctx_super_deps base_ctx.ctx_constructor_deps false false true + (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 diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 0cbe2cee5cf..5313b011d5d 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -210,7 +210,7 @@ let generate baseCtx class_def = (* 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 class_def) "*" + CppReferences.find_referenced_types_flags ctx (TClassDecl class_def) None ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable in List.iter2 diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 808fc6e39a4..8e4f64ce3f4 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -33,7 +33,7 @@ let generate baseCtx enum_def = cpp_file#write_h "#include \n\n"; - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) "*" ctx.ctx_super_deps (Hashtbl.create 0) false false false in + let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) None ctx.ctx_super_deps (Hashtbl.create 0) false false false in List.iter (add_include cpp_file) referenced; begin_namespace output_cpp class_path; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 216eb7e0864..eaa1e144aba 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -92,7 +92,7 @@ let gen_forward_decls h_file interface_def ctx common_ctx = (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) "*" ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable in List.iter2 diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index 703b9458f60..48a44ba0cc9 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -16,7 +16,7 @@ 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 types = ref PMap.empty in (if for_depends then let include_files = @@ -171,8 +171,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 @@ -230,7 +233,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 From 328ab645de193393113c2149d9ff534efe48d951 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 23:43:41 +0100 Subject: [PATCH 10/97] path Map --- src/generators/cpp/cppContext.ml | 8 +- src/generators/cpp/gen/cppCppia.ml | 6 +- src/generators/cpp/gen/cppGen.ml | 4 +- src/generators/cpp/gen/cppGenClassHeader.ml | 4 +- .../cpp/gen/cppGenClassImplementation.ml | 84 ---------------- src/generators/cpp/gen/cppGenEnum.ml | 2 +- .../cpp/gen/cppGenInterfaceHeader.ml | 2 +- src/generators/cpp/gen/cppReferences.ml | 6 +- src/generators/gencpp.ml | 96 +++++++++---------- 9 files changed, 64 insertions(+), 148 deletions(-) diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index 76bfe89c0f3..22c379e0a82 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -6,6 +6,8 @@ open Common open Globals open CppAstTools +module PathMap = Map.Make(struct type t = path let compare i1 i2 = String.compare (s_type_path i2) (s_type_path i1) end) + (* CPP code generation context *) (* ctx_debug_level @@ -30,11 +32,11 @@ type context = { ctx_is_header : bool; ctx_interface_slot : (string, int) Hashtbl.t ref; ctx_interface_slot_count : int ref; - ctx_super_deps : (path, path list) Hashtbl.t; - ctx_constructor_deps : (path, tclass_field) Hashtbl.t; + ctx_super_deps : path list PathMap.t; + ctx_constructor_deps : tclass_field 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 super_deps constructor_deps = diff --git a/src/generators/cpp/gen/cppCppia.ml b/src/generators/cpp/gen/cppCppia.ml index 2d9259d88d1..7a0dc0dd476 100644 --- a/src/generators/cpp/gen/cppCppia.ml +++ b/src/generators/cpp/gen/cppCppia.ml @@ -450,7 +450,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 = @@ -465,7 +465,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" @@ -482,7 +482,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 9d48c3e699e..462736b47bb 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1654,11 +1654,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 + CppContext.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 + CppContext.PathMap.empty false true false in let generate_startup filename is_main = (*make_class_directories base_dir ( "src" :: []);*) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 5313b011d5d..eb05fd75810 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -45,7 +45,7 @@ let gen_member_def ctx class_def is_static field = let key = join_class_path class_def.cl_path "." ^ "." ^ field.cf_name in - try output (Hashtbl.find ctx.ctx_class_member_types key) + try output (StringMap.find key ctx.ctx_class_member_types) with Not_found -> () else output "virtual "); output (if return_type = "Void" then "void" else return_type); @@ -211,7 +211,7 @@ let generate baseCtx class_def = (ie, not the implementation) *) let header_referenced, header_flags = CppReferences.find_referenced_types_flags ctx (TClassDecl class_def) None - ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable + ctx.ctx_super_deps CppContext.PathMap.empty true false scriptable in List.iter2 (fun r f -> gen_forward_decl h_file r f) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 92b8a4bdd78..c51529494f4 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -207,90 +207,6 @@ let gen_field_init ctx class_def field = gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr | _ -> () -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" - 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" - | _ -> () - in - List.iter dump_delegate class_def.cl_ordered_fields; - - output "@end\n\n" - let generate baseCtx class_def = let common_ctx = baseCtx.ctx_common in let class_path = class_def.cl_path in diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 8e4f64ce3f4..9f5d5a4fbb7 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -33,7 +33,7 @@ let generate baseCtx enum_def = cpp_file#write_h "#include \n\n"; - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) None ctx.ctx_super_deps (Hashtbl.create 0) false false false in + let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) None ctx.ctx_super_deps CppContext.PathMap.empty false false false in List.iter (add_include cpp_file) referenced; begin_namespace output_cpp class_path; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index eaa1e144aba..e42cbe0204c 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -92,7 +92,7 @@ let gen_forward_decls h_file interface_def ctx common_ctx = (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps (Hashtbl.create 0) true false scriptable + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps CppContext.PathMap.empty true false scriptable in List.iter2 diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index 48a44ba0cc9..f168e917f5f 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -29,7 +29,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade 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) (CppContext.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 = @@ -120,7 +120,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade | TNew (klass, params, _) -> ( visit_type (TInst (klass, params)); try - let construct_type = Hashtbl.find constructor_deps klass.cl_path in + let construct_type = CppContext.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 ... *) @@ -140,7 +140,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade | TInst (klass, params) -> ( try let construct_type = - Hashtbl.find constructor_deps klass.cl_path + CppContext.PathMap.find klass.cl_path constructor_deps in visit_type construct_type.cf_type with Not_found -> ()) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 55ba98a7db7..e92c4052c38 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -178,65 +178,63 @@ 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 + List.fold_left (fun 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) StringMap.empty common_ctx.types (* 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))) + (match (t, pl) with + | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false + | _ -> not (is_native_gen_class t))) in - let iterator object_def = + let folder acc 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 + 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 + + CppContext.PathMap.add class_def.cl_path deps acc | TEnumDecl enum_def when not (has_enum_flag enum_def EnExtern) -> - Hashtbl.add result enum_def.e_path [] - | _ -> () + CppContext.PathMap.add enum_def.e_path [] acc + | _ -> + acc in - List.iter iterator common_ctx.types; - result + List.fold_left folder CppContext.PathMap.empty common_ctx.types 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 + 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 -> CppContext.PathMap.add class_def.cl_path func acc + | None -> acc) + | _ -> acc) + CppContext.PathMap.empty + common_ctx.types let is_assign_op op = match op with @@ -335,7 +333,7 @@ let generate_source ctx = | TEnumDecl enum_def -> make_id (class_text enum_def.e_path) 0; - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps (Hashtbl.create 0) false true false in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in let acc_decls = (Enum enum_def) :: 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 @@ -456,7 +454,7 @@ let generate common_ctx = let super_deps = create_super_dependencies common_ctx in let constructor_deps = create_constructor_dependencies common_ctx in if (Common.defined common_ctx Define.Cppia) then begin - let ctx = new_context common_ctx debug_level (ref PMap.empty) (Hashtbl.create 0) super_deps constructor_deps 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) super_deps constructor_deps in From 9fe38ea918dfab275c719970a41f5cc3eab22729 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 18 Oct 2024 23:59:21 +0100 Subject: [PATCH 11/97] Add back objc guard --- src/generators/gencpp.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index e92c4052c38..a3881d9374a 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -263,11 +263,6 @@ let generate_source ctx = let scriptable = (Common.defined common_ctx Define.Scriptable) in let existingIds = Hashtbl.create 0 in - (* (if not (Common.defined common_ctx Define.Objc) then match object_def 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 - | _ -> ()); *) - let initial = { extern_src = []; build_xml = ""; @@ -290,6 +285,12 @@ let generate_source ctx = end in let folder acc cur = + (if not (Common.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 cur with | TClassDecl class_def when is_extern_class class_def -> let acc_build_xml = acc.build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml) in From 145e55f0c007498513ef4024fb2f963fb95501f6 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 19 Oct 2024 12:18:15 +0100 Subject: [PATCH 12/97] calculate IDs up front --- src/generators/cpp/cppAst.ml | 17 +++- src/generators/cpp/cppContext.ml | 2 - src/generators/cpp/gen/cppGenClassHeader.ml | 17 ++-- .../cpp/gen/cppGenClassImplementation.ml | 36 +++----- src/generators/cpp/gen/cppGenEnum.ml | 13 ++- src/generators/gencpp.ml | 88 ++++++++++++------- 6 files changed, 95 insertions(+), 78 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 84399c3246b..53bdc732e13 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -157,9 +157,20 @@ and tcpp_expr_expr = | CppCastProtocol of tcppexpr * tclass | CppCastNative of tcppexpr +and tcpp_class = { + cl_class : tclass; + cl_id : int32; + cl_parent_ids : int32 list; +} + +and tcpp_enum = { + e_enum : tenum; + e_id : int32; +} + and tcpp_decl = - | ManagedClass of tclass - | NativeClass of tclass + | ManagedClass of tcpp_class + | NativeClass of tcpp_class | ManagedInterface of tclass | NativeInterface of tclass - | Enum of tenum \ No newline at end of file + | Enum of tcpp_enum \ No newline at end of file diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index 22c379e0a82..94b1671d509 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -24,7 +24,6 @@ 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; @@ -49,7 +48,6 @@ let new_context common_ctx debug file_info member_types super_deps constructor_d 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); diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index eb05fd75810..4be8d1b3af8 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -135,8 +135,9 @@ let gen_member_def ctx class_def is_static field = output ("\t\tDynamic set_" ^ field.cf_name ^ ";\n") | _ -> ())) -let generate baseCtx class_def = - let common_ctx = baseCtx.ctx_common in +let generate base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.cl_class 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 @@ -157,13 +158,13 @@ let generate baseCtx class_def = let debug = if Meta.has Meta.NoDebug class_def.cl_meta - || Common.defined baseCtx.ctx_common Define.NoDebug + || Common.defined base_ctx.ctx_common Define.NoDebug then 0 else 1 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 ctx = file_context base_ctx h_file debug true in let strq = strq ctx.ctx_common in let parent, super = @@ -259,11 +260,7 @@ let generate baseCtx class_def = (* native interface *) CppGen.generate_native_constructor ctx output_h class_def true else ( - let classId = - try Hashtbl.find baseCtx.ctx_type_ids (class_text class_def.cl_path) - with Not_found -> Int32.zero - in - let classIdTxt = Printf.sprintf "0x%08lx" classId in + let classIdTxt = Printf.sprintf "0x%08lx" tcpp_class.cl_id in output_h ("\t\t" ^ class_name ^ "();\n"); output_h "\n\tpublic:\n"; @@ -280,7 +277,7 @@ let generate baseCtx class_def = ^ "," ^ gcName ^ "); }\n"); if has_class_flag class_def CAbstract then output_h "\n" else if - can_inline_constructor baseCtx class_def + can_inline_constructor base_ctx class_def then ( output_h "\n"; CppGen.generate_constructor ctx diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index c51529494f4..57aa7c60eba 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -207,12 +207,13 @@ let gen_field_init ctx class_def field = gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr | _ -> () -let generate baseCtx class_def = - let common_ctx = baseCtx.ctx_common in +let generate base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.cl_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 = base_ctx.ctx_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 @@ -305,25 +306,9 @@ let generate baseCtx class_def = ^ 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 implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.cl_id :: tcpp_class.cl_parent_ids) in let txt cId = Printf.sprintf "0x%08lx" cId in let rec dump_classes indent classes = match classes with @@ -331,8 +316,7 @@ let generate baseCtx class_def = | [ 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") + (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 @@ -449,7 +433,7 @@ let generate baseCtx class_def = (match TClass.get_cl_init class_def with | Some expression -> - let ctx = file_context baseCtx cpp_file debug false in + let ctx = file_context base_ctx cpp_file debug false in output_cpp ("void " ^ class_name ^ "::__init__()"); gen_cpp_init ctx (cpp_class_name class_def) "__init__" "" (mk_block expression); @@ -499,7 +483,7 @@ let generate baseCtx class_def = output_cpp "}\n"); let inline_constructor = - can_inline_constructor baseCtx class_def + can_inline_constructor base_ctx class_def in if (not nativeGen) && (not inline_constructor)&& not (has_class_flag class_def CAbstract) then generate_constructor ctx output_cpp class_def false diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 9f5d5a4fbb7..d714b98c527 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -12,8 +12,9 @@ open CppSourceWriter open CppContext open CppGen -let generate baseCtx enum_def = - let common_ctx = baseCtx.ctx_common in +let generate base_ctx tcpp_enum = + let common_ctx = base_ctx.ctx_common in + let enum_def = tcpp_enum.e_enum in let class_path = enum_def.e_path in let just_class_name = (snd class_path) in let class_name = just_class_name ^ "_obj" in @@ -22,14 +23,12 @@ let generate baseCtx enum_def = let output_cpp = (cpp_file#write) in let debug = if (Meta.has Meta.NoDebug enum_def.e_meta) || ( Common.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.e_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"; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a3881d9374a..4a1366f2dce 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -253,15 +253,54 @@ type gensrc_ctx = { nonboot_classes : path list; boot_enums : path list; exe_classes : (path * path list * module_type) list; + ids : int32 CppContext.PathMap.t; decls : tcpp_decl list; } +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 *) + (* || CppContext.PathMap.to_list ids |> List.exists (fun (_, v) -> v = id) *) + id < Int32.of_int 100 + in + + let rec make_id seed = + let id = gen_hash32 seed class_name in + if needs_new_id id then + make_id (seed + 100) + else + id + in + + match CppContext.PathMap.find_opt path ids with + | Some existing -> + (existing, ids) + | None -> + let new_id = make_id 0 in + (new_id, CppContext.PathMap.add path new_id ids) + +let get_class_ids class_def ids = + let self_id, all_ids = get_id class_def.cl_path ids in + let rec parents acc class_def = + match class_def.cl_super with + | Some (super, _) -> parents (super :: acc) super + | None -> acc in + + let folder (parents, all_ids) class_def = + let new_id, all_ids = get_id class_def.cl_path all_ids in + (new_id :: parents, all_ids) + in + let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in + + (self_id, parent_ids, all_ids) + let generate_source ctx = let common_ctx = ctx.ctx_common in make_base_directory common_ctx.file; let main_deps = ref [] in let scriptable = (Common.defined common_ctx Define.Scriptable) in - let existingIds = Hashtbl.create 0 in let initial = { extern_src = []; @@ -271,19 +310,10 @@ let generate_source ctx = nonboot_classes = []; boot_enums = []; exe_classes = []; + ids = CppContext.PathMap.empty; decls = []; } in - let rec make_id 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 - make_id class_name (seed+100) - else begin - Hashtbl.add existingIds id true; - Hashtbl.add ctx.ctx_type_ids class_name id; - end in - let folder acc cur = (if not (Common.defined common_ctx Define.Objc) then match cur with @@ -305,13 +335,12 @@ let generate_source ctx = acc | TClassDecl class_def -> - make_id (class_text class_def.cl_path) 0; - + let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in let decl = match has_class_flag class_def CInterface with | true -> if native_gen then (NativeInterface class_def) else (ManagedInterface class_def) - | false -> if native_gen then (NativeClass class_def) else (ManagedClass class_def) in + | false -> if native_gen then (NativeClass { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_ids }) else (ManagedClass { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_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 @@ -326,20 +355,19 @@ let generate_source ctx = (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 } + { 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 = all_ids } | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> acc | TEnumDecl enum_def -> - make_id (class_text enum_def.e_path) 0; - - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in - let acc_decls = (Enum enum_def) :: 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 + let self_id, all_ids = get_id enum_def.e_path acc.ids in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in + let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: 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 } + { acc with decls = acc_decls; boot_enums = acc_boot_enums; exe_classes = acc_exe_classes; ids = all_ids } | _ -> acc in @@ -347,19 +375,19 @@ let generate_source ctx = List.iter (fun tcpp_type -> match tcpp_type with - | ManagedClass class_def -> - CppGenClassHeader.generate ctx class_def; - CppGenClassImplementation.generate ctx class_def; - | NativeClass class_def -> - CppGenClassHeader.generate ctx class_def; - CppGenClassImplementation.generate ctx class_def; + | ManagedClass tcpp_class -> + CppGenClassHeader.generate ctx tcpp_class; + CppGenClassImplementation.generate ctx tcpp_class; + | NativeClass tcpp_class -> + CppGenClassHeader.generate ctx tcpp_class; + CppGenClassImplementation.generate 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 enum_def -> - CppGenEnum.generate ctx enum_def) srcctx.decls; + | Enum tcpp_enum -> + CppGenEnum.generate ctx tcpp_enum) srcctx.decls; (match common_ctx.main.main_expr with | None -> CppGen.generate_dummy_main common_ctx From ad8bc9af1e21fd182b80b553f7276f8d7efb0eb9 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 19 Oct 2024 12:38:28 +0100 Subject: [PATCH 13/97] separate id lookup table --- src/generators/gencpp.ml | 52 +++++++++++++++++++++------------------- 1 file changed, 28 insertions(+), 24 deletions(-) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 4a1366f2dce..98efdf9eafe 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -253,17 +253,20 @@ type gensrc_ctx = { nonboot_classes : path list; boot_enums : path list; exe_classes : (path * path list * module_type) list; - ids : int32 CppContext.PathMap.t; decls : tcpp_decl list; + + ids : int32 CppContext.PathMap.t; + (* Keep a separate map with the IDs as the keys *) + (* Prevents us having to iterate through the path map to see if we've got a collision *) + ids_lookup : unit Int32Map.t; } -let rec get_id path ids = +let rec get_id path ids ids_lookup = 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 *) - (* || CppContext.PathMap.to_list ids |> List.exists (fun (_, v) -> v = id) *) - id < Int32.of_int 100 + id < Int32.of_int 100 || Int32Map.mem id ids_lookup in let rec make_id seed = @@ -276,25 +279,25 @@ let rec get_id path ids = match CppContext.PathMap.find_opt path ids with | Some existing -> - (existing, ids) + (existing, ids, ids_lookup) | None -> let new_id = make_id 0 in - (new_id, CppContext.PathMap.add path new_id ids) + (new_id, CppContext.PathMap.add path new_id ids, Int32Map.add new_id () ids_lookup) -let get_class_ids class_def ids = - let self_id, all_ids = get_id class_def.cl_path ids in +let get_class_ids class_def ids ids_lookup = + let self_id, all_ids, all_ids_lookup = get_id class_def.cl_path ids ids_lookup in + + let folder (parents, (all_ids, all_ids_lookup)) class_def = + let new_id, all_ids, all_ids_lookup = get_id class_def.cl_path all_ids all_ids_lookup in + (new_id :: parents, (all_ids, all_ids_lookup)) + in let rec parents acc class_def = match class_def.cl_super with | Some (super, _) -> parents (super :: acc) super | None -> acc in + let parent_ids, (all_ids, all_ids_lookup) = parents [] class_def |> List.fold_left folder ([], (all_ids, all_ids_lookup)) in - let folder (parents, all_ids) class_def = - let new_id, all_ids = get_id class_def.cl_path all_ids in - (new_id :: parents, all_ids) - in - let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in - - (self_id, parent_ids, all_ids) + (self_id, parent_ids, all_ids, all_ids_lookup) let generate_source ctx = let common_ctx = ctx.ctx_common in @@ -310,8 +313,9 @@ let generate_source ctx = nonboot_classes = []; boot_enums = []; exe_classes = []; - ids = CppContext.PathMap.empty; decls = []; + ids = CppContext.PathMap.empty; + ids_lookup = Int32Map.empty; } in let folder acc cur = @@ -335,7 +339,7 @@ let generate_source ctx = acc | TClassDecl class_def -> - let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in + let self_id, parent_ids, all_ids, ids_lookup = get_class_ids class_def acc.ids acc.ids_lookup in let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in let decl = match has_class_flag class_def CInterface with @@ -355,19 +359,19 @@ let generate_source ctx = (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 = all_ids } + { 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 = all_ids; ids_lookup = ids_lookup } | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> acc | TEnumDecl enum_def -> - let self_id, all_ids = get_id enum_def.e_path acc.ids in - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in - let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: 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 + let self_id, all_ids, ids_lookup = get_id enum_def.e_path acc.ids acc.ids_lookup in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in + let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: 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 = all_ids } + { acc with decls = acc_decls; boot_enums = acc_boot_enums; exe_classes = acc_exe_classes; ids = all_ids; ids_lookup = ids_lookup } | _ -> acc in From a9bb14201e080499e78b658347cdf57f80862096 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 19 Oct 2024 13:08:30 +0100 Subject: [PATCH 14/97] Object IDs module to hide cache --- src/generators/gencpp.ml | 63 +++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 26 deletions(-) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 98efdf9eafe..23c37675ddc 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -245,6 +245,21 @@ let is_assign_op op = The common_ctx contains the haxe AST in the "types" field and the resources *) +module ObjectIds = struct + type t = (int32 CppContext.PathMap.t * unit Int32Map.t) + + let empty = (CppContext.PathMap.empty, Int32Map.empty) + + let add path id ((ids, cache):t) = + (CppContext.PathMap.add path id ids, Int32Map.add id () cache) + + let find_opt path ((ids, _):t) = + CppContext.PathMap.find_opt path ids + + let collision id ((_, cache):t) = + Int32Map.mem id cache +end + type gensrc_ctx = { extern_src : string list; build_xml : string; @@ -255,18 +270,15 @@ type gensrc_ctx = { exe_classes : (path * path list * module_type) list; decls : tcpp_decl list; - ids : int32 CppContext.PathMap.t; - (* Keep a separate map with the IDs as the keys *) - (* Prevents us having to iterate through the path map to see if we've got a collision *) - ids_lookup : unit Int32Map.t; + ids : ObjectIds.t; } -let rec get_id path ids ids_lookup = +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 || Int32Map.mem id ids_lookup + id < Int32.of_int 100 || ObjectIds.collision id ids in let rec make_id seed = @@ -277,27 +289,27 @@ let rec get_id path ids ids_lookup = id in - match CppContext.PathMap.find_opt path ids with + match ObjectIds.find_opt path ids with | Some existing -> - (existing, ids, ids_lookup) + (existing, ids) | None -> let new_id = make_id 0 in - (new_id, CppContext.PathMap.add path new_id ids, Int32Map.add new_id () ids_lookup) + (new_id, ObjectIds.add path new_id ids) -let get_class_ids class_def ids ids_lookup = - let self_id, all_ids, all_ids_lookup = get_id class_def.cl_path ids ids_lookup in +let get_class_ids class_def ids = + let self_id, all_ids = get_id class_def.cl_path ids in - let folder (parents, (all_ids, all_ids_lookup)) class_def = - let new_id, all_ids, all_ids_lookup = get_id class_def.cl_path all_ids all_ids_lookup in - (new_id :: parents, (all_ids, all_ids_lookup)) + let folder (parents, all_ids) class_def = + let new_id, all_ids = get_id class_def.cl_path all_ids in + (new_id :: parents, all_ids) in let rec parents acc class_def = match class_def.cl_super with | Some (super, _) -> parents (super :: acc) super | None -> acc in - let parent_ids, (all_ids, all_ids_lookup) = parents [] class_def |> List.fold_left folder ([], (all_ids, all_ids_lookup)) in + let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in - (self_id, parent_ids, all_ids, all_ids_lookup) + (self_id, parent_ids, all_ids) let generate_source ctx = let common_ctx = ctx.ctx_common in @@ -314,8 +326,7 @@ let generate_source ctx = boot_enums = []; exe_classes = []; decls = []; - ids = CppContext.PathMap.empty; - ids_lookup = Int32Map.empty; + ids = ObjectIds.empty; } in let folder acc cur = @@ -339,7 +350,7 @@ let generate_source ctx = acc | TClassDecl class_def -> - let self_id, parent_ids, all_ids, ids_lookup = get_class_ids class_def acc.ids acc.ids_lookup in + let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in let decl = match has_class_flag class_def CInterface with @@ -359,19 +370,19 @@ let generate_source ctx = (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 = all_ids; ids_lookup = ids_lookup } + { 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 = all_ids } | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> acc | TEnumDecl enum_def -> - let self_id, all_ids, ids_lookup = get_id enum_def.e_path acc.ids acc.ids_lookup in - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in - let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: 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 + let self_id, all_ids = get_id enum_def.e_path acc.ids in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in + let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: 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 = all_ids; ids_lookup = ids_lookup } + { acc with decls = acc_decls; boot_enums = acc_boot_enums; exe_classes = acc_exe_classes; ids = all_ids } | _ -> acc in From 631a5d3ee3408fa67e8c9f27dabf165f892faeb4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 19 Oct 2024 16:41:03 +0100 Subject: [PATCH 15/97] remap enum constructors --- src/generators/cpp/cppAst.ml | 7 ++ src/generators/cpp/gen/cppGenEnum.ml | 154 +++++++++++++-------------- src/generators/gencpp.ml | 6 +- 3 files changed, 84 insertions(+), 83 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 53bdc732e13..9e41cab2636 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -163,9 +163,16 @@ and tcpp_class = { cl_parent_ids : int32 list; } +and tcpp_enum_field = { + ef_field : tenum_field; + ef_remapped_name : string; + ef_hashed_name : string; +} + and tcpp_enum = { e_enum : tenum; e_id : int32; + e_constructors : tcpp_enum_field list; } and tcpp_decl = diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index d714b98c527..0ff43a2f3eb 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -12,16 +12,44 @@ open CppSourceWriter open CppContext open CppGen +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.ef_field.ef_type with + | TFun (args, _) -> + Printf.sprintf "%s %s::%s(%s)\n" remap_class_name class_name constructor.ef_remapped_name (print_tfun_arg_list true args) |> output_cpp; + Printf.sprintf "{\n\treturn ::hx::CreateEnum<%s>(%s,%i,%i)" class_name constructor.ef_hashed_name constructor.ef_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.ef_remapped_name ^ ";\n\n" ) + +let gen_static_reflection class_name output_cpp constructor = + let dyn = if constructor_arg_count constructor.ef_field > 0 then "_dyn()" else "" in + Printf.sprintf "\tif (inName==%s) { outValue = %s::%s%s; return true; }\n" constructor.ef_hashed_name class_name constructor.ef_remapped_name dyn |> output_cpp + +let gen_dynamic_constructor class_name output_cpp constructor = + let count = constructor_arg_count constructor.ef_field in + if (count>0) then begin + Printf.sprintf "STATIC_HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, return)\n\n" count class_name constructor.ef_remapped_name |> output_cpp; + end + let generate base_ctx tcpp_enum = let common_ctx = base_ctx.ctx_common in - let enum_def = tcpp_enum.e_enum in - let class_path = enum_def.e_path in + let class_path = tcpp_enum.e_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) || ( Common.defined common_ctx Define.NoDebug) then 0 else 1 in + let debug = if (Meta.has Meta.NoDebug tcpp_enum.e_enum.e_meta) || ( Common.defined common_ctx Define.NoDebug) then 0 else 1 in let ctx = file_context base_ctx cpp_file debug false in let strq = strq ctx.ctx_common in @@ -32,38 +60,16 @@ let generate base_ctx tcpp_enum = cpp_file#write_h "#include \n\n"; - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl enum_def) None ctx.ctx_super_deps CppContext.PathMap.empty false false false in + let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl tcpp_enum.e_enum) None ctx.ctx_super_deps CppContext.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.e_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.e_constructors; output_cpp ("\treturn super::__GetStatic(inName, outValue, inCallProp);\n}\n\n"); output_cpp ("HX_DEFINE_CREATE_ENUM(" ^ class_name ^ ")\n\n"); @@ -73,51 +79,35 @@ let generate base_ctx tcpp_enum = 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.ef_hashed_name constructor.ef_field.ef_index |> output_cpp) + tcpp_enum.e_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.e_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.ef_hashed_name (constructor_arg_count constructor.ef_field) |> output_cpp) + tcpp_enum.e_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.ef_hashed_name ^ ") return " ^ constructor.ef_remapped_name ); + if ( (constructor_arg_count constructor.ef_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.e_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.ef_hashed_name ^ ",\n") ) tcpp_enum.e_constructors; output_cpp "\t::String(null())\n};\n\n"; @@ -141,19 +131,21 @@ let generate base_ctx tcpp_enum = 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.e_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.ef_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.ef_remapped_name class_name constructor.ef_hashed_name constructor.ef_field.ef_index |> output_cpp) + tcpp_enum.e_constructors; + output_cpp ("}\n\n"); output_cpp "\n"; @@ -169,7 +161,7 @@ let generate base_ctx tcpp_enum = 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.e_enum.e_meta Meta.HeaderCode ); begin_namespace output_h class_path; @@ -188,19 +180,17 @@ let generate base_ctx tcpp_enum = 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.ef_remapped_name |> output_h; + match constructor.ef_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.ef_remapped_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.ef_remapped_name constructor.ef_remapped_name |> output_h;) + tcpp_enum.e_constructors; output_h "};\n\n"; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 23c37675ddc..c195d8c357e 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -378,7 +378,11 @@ let generate_source ctx = | TEnumDecl enum_def -> let self_id, all_ids = get_id enum_def.e_path acc.ids in let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in - let acc_decls = (Enum { e_enum = enum_def; e_id = self_id }) :: acc.decls in + let strq = strq ctx.ctx_common in + let sort_constructors f1 f2 = + f2.ef_index - f1.ef_index in + let constructors = enum_def.e_constrs |> pmap_values |> List.sort sort_constructors |> List.map (fun f -> { ef_field = f; ef_remapped_name = keyword_remap f.ef_name; ef_hashed_name = strq f.ef_name}) in + let acc_decls = (Enum { e_enum = enum_def; e_id = self_id; e_constructors = constructors }) :: 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 From 9f59eddab5df9d1418001d66bf0e28c5466d527d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 19 Oct 2024 21:50:10 +0100 Subject: [PATCH 16/97] more interface dead code removal --- src/generators/cpp/gen/cppGenInterfaceHeader.ml | 14 +++++--------- src/generators/gencpp.ml | 2 +- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index e42cbe0204c..315f5b744a8 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -22,7 +22,7 @@ let attribs common_ctx = match Common.defined common_ctx Define.DllExport with | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" | false -> "HXCPP_CLASS_ATTRIBUTES" -let gen_member_def ctx class_def is_static field = +let gen_member_def ctx class_def field = match (follow field.cf_type, field.cf_kind) with | _, Method MethDynamic -> () | TFun (args, return_type), Method _ -> @@ -31,11 +31,11 @@ let gen_member_def ctx class_def is_static field = let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in let gen_args = print_tfun_arg_list true in - if is_static || nativeGen then ( - output ((if is_static then "\t\t" else "\t\tvirtual ") ^ type_to_string return_type); + if nativeGen then ( + output ("\t\tvirtual " ^ type_to_string return_type); output (" " ^ remap_name ^ "( "); output (gen_args args); - output (if is_static then ");\n" else ")=0;\n"); + output ")=0;\n"; if reflective class_def field then if Common.defined ctx.ctx_common Define.DynamicInterfaceClosures then output @@ -113,13 +113,9 @@ let gen_body interface_def ctx output_h = | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") | _ -> (); - interface_def.cl_ordered_statics - |> List.filter should_implement_field - |> List.iter (gen_member_def ctx interface_def true); - interface_def |> all_virtual_functions - |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def false field); + |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def field); match get_meta_string interface_def.cl_meta Meta.ObjcProtocol with | Some protocol -> diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index c195d8c357e..c956fe614e1 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -380,7 +380,7 @@ let generate_source ctx = let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in let strq = strq ctx.ctx_common in let sort_constructors f1 f2 = - f2.ef_index - f1.ef_index in + f1.ef_index - f2.ef_index in let constructors = enum_def.e_constrs |> pmap_values |> List.sort sort_constructors |> List.map (fun f -> { ef_field = f; ef_remapped_name = keyword_remap f.ef_name; ef_hashed_name = strq f.ef_name}) in let acc_decls = (Enum { e_enum = enum_def; e_id = self_id; e_constructors = constructors }) :: acc.decls in let acc_boot_enums = enum_def.e_path :: acc.boot_enums in From eb7c4bf1e32993c026a634e822380a884d045de4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 20 Oct 2024 12:15:34 +0100 Subject: [PATCH 17/97] tcpp interface type --- src/generators/cpp/cppAst.ml | 11 ++- .../cpp/gen/cppGenInterfaceHeader.ml | 77 ++++++++----------- .../cpp/gen/cppGenInterfaceImplementation.ml | 74 +++++++++--------- src/generators/gencpp.ml | 16 +++- 4 files changed, 90 insertions(+), 88 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 9e41cab2636..78ee387d5a7 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -163,6 +163,13 @@ and tcpp_class = { cl_parent_ids : int32 list; } +and tcpp_interface = { + if_class : tclass; + if_name : string; + if_debug_level : int; + if_virtual_functions : (tclass_field * (string * bool * t) list * t) list +} + and tcpp_enum_field = { ef_field : tenum_field; ef_remapped_name : string; @@ -178,6 +185,6 @@ and tcpp_enum = { and tcpp_decl = | ManagedClass of tcpp_class | NativeClass of tcpp_class - | ManagedInterface of tclass - | NativeInterface of tclass + | ManagedInterface of tcpp_interface + | NativeInterface of tcpp_interface | Enum of tcpp_enum \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 315f5b744a8..3c1a6ea8bac 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -12,12 +12,6 @@ open CppSourceWriter open CppContext open CppGen -let calculate_debug_level interface_def base_ctx = - if Meta.has Meta.NoDebug interface_def.cl_meta || Common.defined base_ctx.ctx_common Define.NoDebug then - 0 - else - 1 - let attribs common_ctx = match Common.defined common_ctx Define.DllExport with | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" | false -> "HXCPP_CLASS_ATTRIBUTES" @@ -106,68 +100,65 @@ let gen_header_includes interface_def output_h = let printer inc = output_h ("#include \"" ^ inc ^ "\"\n") in List.iter printer includes -let gen_body interface_def ctx output_h = - if has_boot_field interface_def then output_h "\t\tstatic void __boot();\n"; +let gen_body tcpp_interface ctx output_h = + if has_boot_field tcpp_interface.if_class then output_h "\t\tstatic void __boot();\n"; - match interface_def.cl_array_access with + match tcpp_interface.if_class.cl_array_access with | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") | _ -> (); - interface_def - |> all_virtual_functions - |> List.iter (fun (field, _, _) -> gen_member_def ctx interface_def field); + tcpp_interface.if_virtual_functions + |> List.iter (fun (field, _, _) -> gen_member_def ctx tcpp_interface.if_class field); - match get_meta_string interface_def.cl_meta Meta.ObjcProtocol with + 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 interface_def Meta.HeaderClassCode) + output_h (get_class_code tcpp_interface.if_class Meta.HeaderClassCode) -let generate_native_interface base_ctx interface_def = +let generate_native_interface base_ctx tcpp_interface = let common_ctx = base_ctx.ctx_common in - let class_path = interface_def.cl_path in - let class_name = class_name interface_def in + let class_path = tcpp_interface.if_class.cl_path in let parent, super = - match interface_def.cl_super with + 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 ) + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in + ( "virtual " ^ name, name ) | None -> - ("virtual ::hx::NativeInterface", "::hx::NativeInterface") + ("virtual ::hx::NativeInterface", "::hx::NativeInterface") in let h_file = new_header_file common_ctx common_ctx.file class_path in - let debug = calculate_debug_level interface_def base_ctx in - let ctx = file_context base_ctx h_file debug true 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 interface_def; - gen_forward_decls h_file interface_def ctx common_ctx; - gen_header_includes interface_def output_h; + gen_includes h_file tcpp_interface.if_class; + gen_forward_decls h_file tcpp_interface.if_class 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 interface_def Meta.HeaderNamespaceCode); + output_h (get_class_code tcpp_interface.if_class Meta.HeaderNamespaceCode); - output_h ("class " ^ (attribs common_ctx) ^ " " ^ class_name ^ " : public " ^ parent); + output_h ("class " ^ (attribs common_ctx) ^ " " ^ tcpp_interface.if_name ^ " : public " ^ parent); - interface_def.cl_implements + 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 " ^ class_name ^ " OBJ_;\n"); + output_h ("\t\ttypedef " ^ tcpp_interface.if_name ^ " OBJ_;\n"); - CppGen.generate_native_constructor ctx output_h interface_def true; + CppGen.generate_native_constructor ctx output_h tcpp_interface.if_class true; - gen_body interface_def ctx output_h; + gen_body tcpp_interface ctx output_h; output_h "};\n\n"; @@ -176,13 +167,12 @@ let generate_native_interface base_ctx interface_def = h_file#close -let generate_managed_interface base_ctx interface_def = +let generate_managed_interface base_ctx tcpp_interface = let common_ctx = base_ctx.ctx_common in - let class_path = interface_def.cl_path in - let class_name = class_name interface_def in + let class_path = tcpp_interface.if_class.cl_path in let parent, super = - match interface_def.cl_super with + match tcpp_interface.if_class.cl_super with | Some (klass, params) -> let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in ( name, name ) @@ -190,27 +180,26 @@ let generate_managed_interface base_ctx interface_def = ("", "::hx::Object") in let h_file = new_header_file common_ctx common_ctx.file class_path in - let debug = calculate_debug_level interface_def base_ctx in - let ctx = file_context base_ctx h_file debug true 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 interface_def; - gen_forward_decls h_file interface_def ctx common_ctx; - gen_header_includes interface_def output_h; + gen_includes h_file tcpp_interface.if_class; + gen_forward_decls h_file tcpp_interface.if_class 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 interface_def Meta.HeaderNamespaceCode); + output_h (get_class_code tcpp_interface.if_class Meta.HeaderNamespaceCode); - output_h ("class " ^ (attribs common_ctx) ^ " " ^ class_name ^ " {\n"); + 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 interface_def ctx output_h; + gen_body tcpp_interface ctx output_h; output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 647eed0c244..e2786e085fe 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -108,25 +108,24 @@ let generate_protocol_delegate ctx class_def output = output "@end\n\n" -let generate_managed_interface baseCtx class_def = - let common_ctx = baseCtx.ctx_common 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 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 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 - let scriptable = Common.defined common_ctx Define.Scriptable && not class_def.cl_private in + let scriptable = Common.defined common_ctx Define.Scriptable && not tcpp_interface.if_class.cl_private in - if debug > 1 then + if tcpp_interface.if_debug_level > 1 then print_endline - ("Found class definition:" ^ join_class_path class_def.cl_path "::"); + ("Found interface definition:" ^ join_class_path tcpp_interface.if_class.cl_path "::"); cpp_file#write_h "#include \n\n"; let all_referenced = - CppReferences.find_referenced_types ctx (TClassDecl class_def) ctx.ctx_super_deps + CppReferences.find_referenced_types ctx (TClassDecl tcpp_interface.if_class) ctx.ctx_super_deps ctx.ctx_constructor_deps false false scriptable in List.iter (add_include cpp_file) all_referenced; @@ -135,28 +134,26 @@ let generate_managed_interface baseCtx class_def = 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 + 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 class_def Meta.CppNamespaceCode); - - let class_name = class_name class_def in + output_cpp (get_class_code tcpp_interface.if_class Meta.CppNamespaceCode); output_cpp "\n"; (* cl_interface *) - let implemented_instance_fields = List.filter should_implement_field class_def.cl_ordered_fields in - let reflective_members = List.filter (reflective class_def) implemented_instance_fields in + let implemented_instance_fields = List.filter should_implement_field tcpp_interface.if_class.cl_ordered_fields in + let reflective_members = List.filter (reflective tcpp_interface.if_class) implemented_instance_fields in let sMemberFields = match reflective_members with | [] -> "0 /* sMemberFields */" | _ -> - let memberFields = class_name ^ "_sMemberFields" in + let memberFields = tcpp_interface.if_name ^ "_sMemberFields" in let dump_field_name field = output_cpp ("\t" ^ strq field.cf_name ^ ",\n") in output_cpp ("static ::String " ^ memberFields ^ "[] = {\n"); List.iter dump_field_name reflective_members; @@ -189,7 +186,7 @@ let generate_managed_interface baseCtx class_def = output_cpp "\t}\n"; in - let sctipt_name = class_name ^ "__scriptable" in + let sctipt_name = tcpp_interface.if_name ^ "__scriptable" in output_cpp ("class " ^ sctipt_name ^ " : public ::hx::Object {\n"); output_cpp "public:\n"; @@ -203,7 +200,7 @@ let generate_managed_interface baseCtx class_def = in_list in - list_iteri dump_script_field (all_virtual_functions class_def); + list_iteri dump_script_field tcpp_interface.if_virtual_functions; output_cpp "};\n\n"; let generate_script_function field scriptName callName = @@ -218,7 +215,7 @@ let generate_managed_interface baseCtx class_def = output_cpp ("ctx->return" ^ CppCppia.script_type return_type false ^ "("); let signature = - output_cpp (class_name ^ "::" ^ callName ^ "(ctx->getThis()" ^ if List.length args > 0 then "," else ""); + output_cpp (tcpp_interface.if_name ^ "::" ^ callName ^ "(ctx->getThis()" ^ if List.length args > 0 then "," else ""); let signature, _, _ = List.fold_left @@ -241,8 +238,7 @@ let generate_managed_interface baseCtx class_def = in let sigs = Hashtbl.create 0 in - let new_sctipt_functions = all_virtual_functions class_def in - match new_sctipt_functions with + match tcpp_interface.if_virtual_functions with | [] -> output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" | _ -> @@ -250,7 +246,7 @@ let generate_managed_interface baseCtx class_def = (fun (f, _, _) -> let s = generate_script_function f ("__s_" ^ f.cf_name) (keyword_remap f.cf_name) in Hashtbl.add sigs f.cf_name s) - new_sctipt_functions; + tcpp_interface.if_virtual_functions; output_cpp "#ifndef HXCPP_CPPIA_SUPER_ARG\n"; output_cpp "#define HXCPP_CPPIA_SUPER_ARG(x)\n"; @@ -262,56 +258,56 @@ let generate_managed_interface baseCtx class_def = (" ::hx::ScriptNamedFunction(\"" ^ f.cf_name ^ "\",__s_" ^ f.cf_name ^ ",\"" ^ s ^ "\", " ^ isStaticFlag ^ " "); let superCall = - if isStaticFlag = "true" || has_class_flag class_def CInterface then + if isStaticFlag = "true" || has_class_flag tcpp_interface.if_class 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 "false") tcpp_interface.if_virtual_functions; output_cpp " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n"; - output_cpp ("\n\n" ^ class_name ^ " " ^ class_name ^ "_scriptable = {\n"); + output_cpp ("\n\n" ^ tcpp_interface.if_name ^ " " ^ tcpp_interface.if_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; + tcpp_interface.if_virtual_functions; output_cpp "};\n"); let class_name_text = join_class_path class_path "." in - output_cpp ("::hx::Class " ^ class_name ^ "::__mClass;\n\n"); + output_cpp ("::hx::Class " ^ tcpp_interface.if_name ^ "::__mClass;\n\n"); - output_cpp ("void " ^ class_name ^ "::__register()\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)" ^ cpp_class_hash class_def ^ " >;\n"); + output_cpp ("\t__mClass->mCanCast = ::hx::TIsInterface< (int)" ^ cpp_class_hash tcpp_interface.if_class ^ " >;\n"); output_cpp "\t::hx::_hx_RegisterClass(__mClass->mName, __mClass);\n"; if scriptable then - output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," ^ class_name ^ ");\n"); + output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," ^ tcpp_interface.if_name ^ ");\n"); output_cpp "}\n\n"; - if has_boot_field class_def then ( - output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); + if has_boot_field tcpp_interface.if_class then ( + output_cpp ("void " ^ tcpp_interface.if_name ^ "::__boot()\n{\n"); List.iter - (gen_field_init ctx class_def) - (List.filter should_implement_field class_def.cl_ordered_statics); + (gen_field_init ctx tcpp_interface.if_class) + (List.filter should_implement_field tcpp_interface.if_class.cl_ordered_statics); output_cpp "}\n\n"); end_namespace output_cpp class_path; - if Meta.has Meta.ObjcProtocol class_def.cl_meta then ( + 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 class_def.cl_meta Meta.ObjcProtocol |> Option.default "" in - generate_protocol_delegate ctx class_def output_cpp; + let protocol = get_meta_string tcpp_interface.if_class.cl_meta Meta.ObjcProtocol |> Option.default "" in + generate_protocol_delegate ctx tcpp_interface.if_class 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"); diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index c956fe614e1..0ea8d515d8b 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -351,11 +351,21 @@ let generate_source ctx = | TClassDecl class_def -> let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in - let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in + let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in + let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in let decl = match has_class_flag class_def CInterface with - | true -> if native_gen then (NativeInterface class_def) else (ManagedInterface class_def) - | false -> if native_gen then (NativeClass { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_ids }) else (ManagedClass { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_ids }) in + | true -> + let iface = { + if_class = class_def; + if_name = class_name class_def; + if_debug_level = debug_level; + if_virtual_functions = all_virtual_functions class_def; + } in + if native_gen then (NativeInterface iface) else (ManagedInterface iface) + | false -> + let cls = { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_ids } in + if native_gen then (NativeClass cls) else (ManagedClass cls) in let acc_decls = decl :: acc.decls in let acc_build_xml = acc.build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml) in From 95a740731603846a44e5a9460c4e3083561941d4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 20 Oct 2024 16:02:35 +0100 Subject: [PATCH 18/97] name, flags, and debug level in tcpp_class --- src/generators/cpp/cppAst.ml | 8 ++++++ src/generators/cpp/cppAstTools.ml | 8 +++++- src/generators/cpp/gen/cppGenClassHeader.ml | 8 +++--- .../cpp/gen/cppGenClassImplementation.ml | 8 ++---- src/generators/gencpp.ml | 28 ++++++++++++++++++- 5 files changed, 49 insertions(+), 11 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 78ee387d5a7..76b6df85473 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -157,10 +157,18 @@ and tcpp_expr_expr = | CppCastProtocol of tcppexpr * tclass | CppCastNative of tcppexpr +and tcpp_class_flags = + | QuickAlloc + | Container + | Scriptable + and tcpp_class = { cl_class : tclass; + cl_name : string; cl_id : int32; cl_parent_ids : int32 list; + cl_flags : int; + cl_debug_level : int; } and tcpp_interface = { diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index ecbdb5c3b70..732640303cd 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -727,4 +727,10 @@ let enum_getter_type t = | TCppScalar "int" -> "Int" | TCppScalar "bool" -> "Bool" | TCppScalar x -> x - | _ -> "Object" \ No newline at end of file + | _ -> "Object" + +let int_of_tcpp_class_flag (flag:tcpp_class_flags) = + Obj.magic flag + +let has_tcpp_class_flag c flag = + has_flag c.cl_flags (int_of_tcpp_class_flag flag) \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 4be8d1b3af8..c3e8c68c879 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -141,12 +141,12 @@ let generate base_ctx tcpp_class = 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 = Common.defined common_ctx Define.Scriptable && not class_def.cl_private in - let class_name = class_name class_def in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in + let class_name = tcpp_class.cl_name in let ptr_name = class_pointer class_def in - let can_quick_alloc = can_quick_alloc 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 isContainer = if has_gc_references class_def then "true" else "false" in + let isContainer = if has_tcpp_class_flag tcpp_class Container 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 = diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 57aa7c60eba..725a2c16f22 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -211,15 +211,13 @@ let generate base_ctx tcpp_class = let common_ctx = base_ctx.ctx_common in let class_def = tcpp_class.cl_class in let class_path = class_def.cl_path in - let debug = base_ctx.ctx_debug_level in + let debug = tcpp_class.cl_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 = - Common.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 @@ -254,7 +252,7 @@ let generate base_ctx tcpp_class = 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.cl_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 diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 0ea8d515d8b..62f908ef0ca 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -364,7 +364,33 @@ let generate_source ctx = } in if native_gen then (NativeInterface iface) else (ManagedInterface iface) | false -> - let cls = { cl_class = class_def; cl_id = self_id; cl_parent_ids = parent_ids } in + let flags = + if Common.defined common_ctx Define.Scriptable && not class_def.cl_private then + set_flag 0 (int_of_tcpp_class_flag Scriptable) + else + 0 + in + let flags = + if CppGen.can_quick_alloc class_def then + set_flag flags (int_of_tcpp_class_flag QuickAlloc) + else + flags + in + let flags = + if CppGen.has_gc_references class_def then + set_flag flags (int_of_tcpp_class_flag Container) + else + flags + in + + let cls = { + cl_class = class_def; + cl_id = self_id; + cl_name = class_name class_def; + cl_flags = flags; + cl_parent_ids = parent_ids; + cl_debug_level = debug_level; + } in if native_gen then (NativeClass cls) else (ManagedClass cls) in let acc_decls = decl :: acc.decls in From 5200fb358970d4cadbd7f1d65ccb4a9e2bd3834e Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 20 Oct 2024 19:14:29 +0100 Subject: [PATCH 19/97] remove unused constructor var list return item --- src/generators/cpp/gen/cppGen.ml | 55 +++++++++---------- src/generators/cpp/gen/cppGenClassHeader.ml | 23 +++----- .../cpp/gen/cppGenClassImplementation.ml | 12 ++-- 3 files changed, 38 insertions(+), 52 deletions(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 462736b47bb..74669b1825c 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1862,33 +1862,28 @@ 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.cl_name in + let ptr_name = class_pointer tcpp_class.cl_class in + let can_quick_alloc = has_tcpp_class_flag tcpp_class QuickAlloc in + let gcName = gen_gc_name tcpp_class.cl_class.cl_path in + let isContainer = if has_tcpp_class_flag tcpp_class Container then "true" else "false" in + let cargs = constructor_arg_var_list tcpp_class.cl_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 @@ -1922,16 +1917,16 @@ let generate_constructor ctx out class_def isHeader = | Some super -> dump_dynamic (fst super) | _ -> () in - dump_dynamic class_def; + dump_dynamic tcpp_class.cl_class; if isHeader then - match class_def.cl_constructor with + match tcpp_class.cl_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.cl_class false "new" function_def "" "" no_debug; out "\n") | _ -> () @@ -1941,12 +1936,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 diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index c3e8c68c879..b74683ffd3b 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -147,24 +147,15 @@ let generate base_ctx tcpp_class = let can_quick_alloc = has_tcpp_class_flag tcpp_class QuickAlloc in let gcName = gen_gc_name class_def.cl_path in let isContainer = if has_tcpp_class_flag tcpp_class Container 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) - in - (*let cpp_file = new_cpp_file common_ctx.file class_path in*) - let debug = - if - Meta.has Meta.NoDebug class_def.cl_meta - || Common.defined base_ctx.ctx_common Define.NoDebug - then 0 - else 1 - in + let constructor_type_args = + tcpp_class.cl_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 debug true in + let ctx = file_context base_ctx h_file tcpp_class.cl_debug_level true in let strq = strq ctx.ctx_common in let parent, super = @@ -282,7 +273,7 @@ let generate base_ctx tcpp_class = output_h "\n"; CppGen.generate_constructor ctx (fun str -> output_h ("\t\t" ^ str)) - class_def true) + tcpp_class true) else ( output_h ("\t\tstatic " ^ ptr_name ^ " __new(" ^ constructor_type_args ^ ");\n"); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 725a2c16f22..3e7265da63d 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -254,12 +254,12 @@ let generate base_ctx tcpp_class = let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in let class_name = tcpp_class.cl_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) - in + cargs + |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) + |> String.concat "," in + let haxe_implementations, native_implementations = implementations class_def in @@ -484,7 +484,7 @@ let generate base_ctx tcpp_class = can_inline_constructor base_ctx class_def in if (not nativeGen) && (not inline_constructor)&& not (has_class_flag class_def CAbstract) then - generate_constructor ctx output_cpp class_def false + generate_constructor ctx output_cpp tcpp_class false else if nativeGen then generate_native_constructor ctx output_cpp class_def false; From fde882b68c409995d1007bdaacced3407e39f4e4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 22 Oct 2024 17:49:21 +0100 Subject: [PATCH 20/97] separate out header field generation --- src/generators/cpp/cppAst.ml | 11 + src/generators/cpp/cppRetyper.ml | 18 ++ src/generators/cpp/gen/cppGenClassHeader.ml | 288 ++++++++++-------- .../cpp/gen/cppGenInterfaceHeader.ml | 4 - 4 files changed, 197 insertions(+), 124 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 76b6df85473..ba1078211a3 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -169,6 +169,17 @@ and tcpp_class = { cl_parent_ids : int32 list; cl_flags : int; cl_debug_level : int; + + (* cl_static_variables : tclass_field list; + cl_static_properties : tclass_field list; + cl_static_functions : tclass_field list; + cb_static_dynamic_functions : tclass_field list; + + cl_variables : tclass_field list; + cl_properties : tclass_field list; + cl_functions : tclass_field list; + cb_dynamic_functions : tclass_field list; + cl_abstracts : tclass_field list; *) } and tcpp_interface = { diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 8aea5442f50..dadc1d805f6 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1432,3 +1432,21 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> cppExpr in retype request_type expression_tree + +(* let remap_to_class class_def = + let get_all_paths cls = + match CppStrings.get_all_meta_string_path cls.cl_meta Meta.Include with + | [] -> [ class_def.cl_path ] + | files -> List.map CppStrings.path_of_string files in + + let parent_includes = + match class_def.cl_super with + | Some (klass, _) -> get_all_paths klass + | _ -> [] in + + let implements_includes = + class_def.cl_implements + |> CppGen.real_interfaces + |> List.map (fun (interface, _) -> get_all_paths interface) + |> List.flatten in + () *) \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index b74683ffd3b..73a2c4cd87b 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -12,109 +12,27 @@ open CppSourceWriter open CppContext open CppGen -let gen_member_def ctx class_def is_static field = - let output = ctx.ctx_output in +let gen_member_variable ctx class_def is_static field = + let tcpp = cpp_type_of field.cf_type in + let tcpp_str = tcpp_to_string tcpp in + + if not is_static && only_stack_access field.cf_type 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) 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 - 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 = - Common.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 (StringMap.find key ctx.ctx_class_member_types) - 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")); + Printf.sprintf "%s%s %s;\n" suffix tcpp_str remap_name |> output; + + if not is_static && is_gc_element ctx tcpp 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 remap_name tcpp_str get_ptr remap_name |> output; (* Add a "dyn" function for variable to unify variable/function access *) - if (not nativeGen) then + if (not (Meta.has Meta.NativeGen class_def.cl_meta)) then match follow field.cf_type with | TFun (_, _) -> output (if is_static then "\t\tstatic " else "\t\t"); @@ -123,17 +41,86 @@ let gen_member_def ctx class_def is_static field = ^ ";}\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") - | _ -> ()); + | 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") - | _ -> ())) + | 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 gen_dynamic_function ctx class_def is_static field function_def = + let output = ctx.ctx_output in + let remap_name = keyword_remap field.cf_name in + let is_not_static = not is_static in + let prefix = if is_static then "\t\tstatic " else "\t\t" in + + Printf.sprintf "%s::Dynamic %s;\n" prefix remap_name |> output; + + if is_not_static && is_gc_element ctx TCppDynamic then + Printf.sprintf "\t\tinline ::Dynamic _hx_set_%s(::hx::StackContext* _hx_ctx, ::Dynamic _hx_v) { HX_OBJ_WB(this, _hx_v.mPtr) return %s = _hx_v; }\n" remap_name remap_name |> output; + + Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix remap_name remap_name |> output + +let gen_abstract_function ctx class_def field tl tr = + 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 + (decls + |> List.find (fun ((n, _, _), _) -> n = name) + |> snd + |> type_constant_value ctx.ctx_common.basic) + | _ -> None + with Not_found -> None + in + + arg_list + |> List.map (fun (n, o, t) -> print_arg n (get_default_value n) t prefix) + |> String.concat "," + in + let output = ctx.ctx_output in + let return_type = type_to_string tr in + let remap_name = native_field_name_remap false field in + + Printf.sprintf + "\t\tvirtual %s %s(%s) %s\n" + (if return_type = "Void" then "void" else return_type) + remap_name + (ctx_arg_list ctx tl "") + (if return_type = "void" then "{}" else "{ return 0; }") |> output; + + if reflective class_def field then Printf.sprintf "\t\t::Dynamic %s_dyn();\n" remap_name |> output + +let gen_member_function ctx class_def is_static field function_def = + let output = ctx.ctx_output in + let is_non_virtual = Meta.has Meta.NonVirtual field.cf_meta in + let is_virtual = not is_non_virtual in + let is_non_static = not is_static in + + if is_virtual && is_non_static then ( + let is_not_scriptable = not (Common.defined ctx.ctx_common Define.Scriptable) in + let is_external_member = not (is_internal_member field.cf_name) in + if is_not_scriptable && is_external_member then + let key = Printf.sprintf "%s.%s" (join_class_path class_def.cl_path ".") field.cf_name in + match StringMap.find_opt key ctx.ctx_class_member_types with + | Some v -> output v + | None -> () + else + output "virtual "); + + let return_type = type_to_string function_def.tf_type in + let return_type_str = if return_type = "Void" then "void" else return_type in + let remap_name = native_field_name_remap is_static field in + let prefix = (if is_static then "\t\tstatic " else "\t\t") in + Printf.sprintf "%s%s %s(%s);\n" prefix return_type_str remap_name (print_arg_list function_def.tf_args "") |> output; + + if (is_non_virtual || not (is_override field)) && reflective class_def field then + Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix remap_name |> output let generate base_ctx tcpp_class = let common_ctx = base_ctx.ctx_common in @@ -425,17 +412,78 @@ let generate base_ctx tcpp_class = if has_boot_field class_def 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") - | _ -> ()); - - List.iter - (gen_member_def ctx class_def true) - (List.filter should_implement_field class_def.cl_ordered_statics); - - List.iter - (gen_member_def ctx class_def false) - (List.filter should_implement_field class_def.cl_ordered_fields); + let filter_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None in + + let filter_dynamic_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None in + + let filter_abstract_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_type) with + | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> + Some (field, tl, tr) + | _ -> + None + else + None in + + let filter_variables field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Var _, _ -> + Some field + (* Below should cause abstracts which have functions with no implementation to be generated as a field *) + | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> + Some field + | _ -> + None + else + None in + + class_def.cl_ordered_statics + |> List.filter_map filter_functions + |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); + + class_def.cl_ordered_statics + |> List.filter_map filter_dynamic_functions + |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); + + class_def.cl_ordered_statics + |> List.filter_map filter_variables + |> List.iter (fun field -> gen_member_variable ctx class_def true field); + + (* *) + + class_def.cl_ordered_fields + |> List.filter_map filter_functions + |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); + + class_def.cl_ordered_fields + |> List.filter_map filter_dynamic_functions + |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); + + class_def.cl_ordered_fields + |> List.filter_map filter_variables + |> List.iter (fun field -> gen_member_variable ctx class_def false field); + + class_def.cl_ordered_fields + |> List.filter_map filter_abstract_functions + |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 3c1a6ea8bac..548639bf5f4 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -103,10 +103,6 @@ let gen_header_includes interface_def output_h = let gen_body tcpp_interface ctx output_h = if has_boot_field tcpp_interface.if_class then output_h "\t\tstatic void __boot();\n"; - match tcpp_interface.if_class.cl_array_access with - | Some t -> output_h ("\t\ttypedef " ^ type_string t ^ " __array_access;\n") - | _ -> (); - tcpp_interface.if_virtual_functions |> List.iter (fun (field, _, _) -> gen_member_def ctx tcpp_interface.if_class field); From 7e716135e616005f9b86a4e1a995027bda2ae69a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 22 Oct 2024 20:10:55 +0100 Subject: [PATCH 21/97] separate managed and native header gen functions --- src/generators/cpp/gen/cppGenClassHeader.ml | 551 +++++++++++++------- src/generators/gencpp.ml | 4 +- 2 files changed, 364 insertions(+), 191 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 73a2c4cd87b..a86b86b80a6 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -122,11 +122,191 @@ let gen_member_function ctx class_def is_static field function_def = if (is_non_virtual || not (is_override field)) && reflective class_def field then Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix remap_name |> output -let generate base_ctx tcpp_class = +let generate_native_header base_ctx tcpp_class = + let common_ctx = base_ctx.ctx_common in + let class_def = tcpp_class.cl_class in + let class_path = class_def.cl_path in + let scriptable = has_tcpp_class_flag tcpp_class Scriptable in + let class_name = tcpp_class.cl_name 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.cl_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 + + begin_header_file h_file#write_h def_string true; + + (* Include the real header file for the super class *) + (match class_def.cl_super with + | Some super -> + let klass = fst super in + let include_files = get_all_meta_string_path klass.cl_meta Meta.Include in + if List.length include_files > 0 then + List.iter + (fun inc -> h_file#add_include (path_of_string inc)) + include_files + else h_file#add_include klass.cl_path + | _ -> ()); + + (* And any interfaces ... *) + List.iter + (fun imp -> + let interface = fst imp in + let include_files = + get_all_meta_string_path interface.cl_meta Meta.Include + in + if List.length include_files > 0 then + List.iter + (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); + + (* 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 class_def) None + ctx.ctx_super_deps CppContext.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); + let includes = + get_all_meta_string_path class_def.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); + + let extern_class = Common.defined common_ctx Define.DllExport in + let attribs = + "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" + in + + 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 initial = if super = "" then [] else [ (Printf.sprintf "public %s" parent) ] in + let all_parents = + class_def.cl_implements + |> List.fold_left folder initial + |> 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 class_name parent_string |> output_h; + + CppGen.generate_native_constructor ctx output_h class_def true; + + if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; + + let filter_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None in + + let filter_dynamic_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None in + + let filter_abstract_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_type) with + | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> + Some (field, tl, tr) + | _ -> + None + else + None in + + let filter_variables field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Var _, _ -> + Some field + (* Below should cause abstracts which have functions with no implementation to be generated as a field *) + | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> + Some field + | _ -> + None + else + None in + + class_def.cl_ordered_statics + |> List.filter_map filter_functions + |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); + + class_def.cl_ordered_statics + |> List.filter_map filter_dynamic_functions + |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); + + class_def.cl_ordered_statics + |> List.filter_map filter_variables + |> List.iter (fun field -> gen_member_variable ctx class_def true field); + + (* *) + + class_def.cl_ordered_fields + |> List.filter_map filter_functions + |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); + + class_def.cl_ordered_fields + |> List.filter_map filter_dynamic_functions + |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); + + class_def.cl_ordered_fields + |> List.filter_map filter_variables + |> List.iter (fun field -> gen_member_variable ctx class_def false field); + + class_def.cl_ordered_fields + |> List.filter_map filter_abstract_functions + |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); + + 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.cl_class 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 = has_tcpp_class_flag tcpp_class Scriptable in let class_name = tcpp_class.cl_name in @@ -152,13 +332,12 @@ let generate base_ctx tcpp_class = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in ( name, name ) - | None when nativeGen -> ("", "") | None -> ("::hx::Object", "::hx::Object") 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 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 @@ -213,202 +392,196 @@ let generate base_ctx tcpp_class = "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) - in - - 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"))); - - if (nativeGen) then - (* native interface *) - CppGen.generate_native_constructor ctx output_h class_def true + 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 initial = if super = "" then [] else [ (Printf.sprintf "public %s" parent) ] in + let all_parents = + class_def.cl_implements + |> List.fold_left folder initial + |> 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 class_name parent_string |> output_h; + 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.cl_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"); + output_h + ("\t\tinline void *operator new(size_t inSize, bool inContainer=" + ^ isContainer ^ ",const char *inName=" ^ gcName ^ ")\n"); + 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"; + 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 base_ctx class_def + then ( + output_h "\n"; + CppGen.generate_constructor ctx + (fun str -> output_h ("\t\t" ^ str)) + tcpp_class true) else ( - let classIdTxt = Printf.sprintf "0x%08lx" tcpp_class.cl_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"); 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 (CppGen.dynamic_functions class_def) > 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_get_member_field class_def 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 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\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 - 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"; + "\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 + 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 - 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 needs_gc_funcs = (not nativeGen) && 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 + if has_compare_field class_def then + output_h + ("\t\tint __Compare(const ::hx::Object *inRHS) const { " + ^ "return const_cast<" ^ class_name + ^ " *>(this)->__compare(Dynamic((::hx::Object *)inRHS)); }\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 "\t\tstatic void __register();\n"; + if has_new_gc_references class_def then ( + output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; + output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\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 + 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 + + 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\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 castKey <> implementationKey then - let glue = - Printf.sprintf "%s_%08lx" field.cf_name - (gen_hash32 0 cast) + 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 - 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") - | _ -> () - in - (match interface.cl_super with - | Some (super, _) -> check_interface super - | _ -> ()); - List.iter check_field interface.cl_ordered_fields + output_h headerCode; + output_h "\n") + | _ -> () in - check_interface src) - haxe_implementations); + (match interface.cl_super with + | Some (super, _) -> check_interface super + | _ -> ()); + List.iter check_field interface.cl_ordered_fields + in + check_interface src) + haxe_implementations); - 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")); + 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"); if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 62f908ef0ca..fe0a3cf87cf 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -431,10 +431,10 @@ let generate_source ctx = List.iter (fun tcpp_type -> match tcpp_type with | ManagedClass tcpp_class -> - CppGenClassHeader.generate ctx tcpp_class; + CppGenClassHeader.generate_managed_header ctx tcpp_class; CppGenClassImplementation.generate ctx tcpp_class; | NativeClass tcpp_class -> - CppGenClassHeader.generate ctx tcpp_class; + CppGenClassHeader.generate_native_header ctx tcpp_class; CppGenClassImplementation.generate ctx tcpp_class; | ManagedInterface interface_def -> CppGenInterfaceHeader.generate_managed_interface ctx interface_def; From 0a17f2cd2c73bfb2a354c461d80a351f7db26b7c Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 22 Oct 2024 20:52:23 +0100 Subject: [PATCH 22/97] move header stuff into shared function --- src/generators/cpp/gen/cppGenClassHeader.ml | 271 ++++++-------------- 1 file changed, 82 insertions(+), 189 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index a86b86b80a6..6e855ba23cf 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -12,6 +12,49 @@ open CppSourceWriter open CppContext open CppGen +let filter_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None + +let filter_dynamic_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None + +let filter_abstract_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_type) with + | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> + Some (field, tl, tr) + | _ -> + None + else + None + +let filter_variables field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Var _, _ -> + Some field + (* Below should cause abstracts which have functions with no implementation to be generated as a field *) + | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> + Some field + | _ -> + None + else + None + let gen_member_variable ctx class_def is_static field = let tcpp = cpp_type_of field.cf_type in let tcpp_str = tcpp_to_string tcpp in @@ -122,32 +165,14 @@ let gen_member_function ctx class_def is_static field function_def = if (is_non_virtual || not (is_override field)) && reflective class_def field then Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix remap_name |> output -let generate_native_header base_ctx tcpp_class = - let common_ctx = base_ctx.ctx_common in - let class_def = tcpp_class.cl_class in - let class_path = class_def.cl_path in - let scriptable = has_tcpp_class_flag tcpp_class Scriptable in - let class_name = tcpp_class.cl_name 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.cl_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 gen_class_header ctx tcpp_class h_file scriptable parents = + let class_path = tcpp_class.cl_class.cl_path in let def_string = join_class_path class_path "_" in - begin_header_file h_file#write_h def_string true; + 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.cl_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 @@ -170,12 +195,14 @@ let generate_native_header base_ctx tcpp_class = (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.cl_class.cl_implements); (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) + let output_h = h_file#write in + let class_path = tcpp_class.cl_class.cl_path in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl class_def) None + CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_class.cl_class) None ctx.ctx_super_deps CppContext.PathMap.empty true false scriptable in List.iter2 @@ -183,18 +210,18 @@ let generate_native_header base_ctx tcpp_class = header_referenced header_flags; output_h "\n"; - output_h (get_class_code class_def Meta.HeaderCode); + output_h (get_class_code tcpp_class.cl_class Meta.HeaderCode); let includes = - get_all_meta_string_path class_def.cl_meta Meta.HeaderInclude + get_all_meta_string_path tcpp_class.cl_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.cl_class Meta.HeaderNamespaceCode); - let extern_class = Common.defined common_ctx Define.DllExport in + let extern_class = Common.defined ctx.ctx_common Define.DllExport in let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" in @@ -205,65 +232,44 @@ let generate_native_header base_ctx tcpp_class = else acc in - let initial = if super = "" then [] else [ (Printf.sprintf "public %s" parent) ] in let all_parents = - class_def.cl_implements - |> List.fold_left folder initial + tcpp_class.cl_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 class_name parent_string |> output_h; + Printf.sprintf "class %s %s%s\n{\n\tpublic:\n" attribs tcpp_class.cl_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.cl_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.cl_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 + + 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_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - let filter_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None in - - let filter_dynamic_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method MethDynamic, Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None in - - let filter_abstract_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_type) with - | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> - Some (field, tl, tr) - | _ -> - None - else - None in - - let filter_variables field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Var _, _ -> - Some field - (* Below should cause abstracts which have functions with no implementation to be generated as a field *) - | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> - Some field - | _ -> - None - else - None in - class_def.cl_ordered_statics |> List.filter_map filter_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); @@ -337,78 +343,8 @@ let generate_managed_header base_ctx tcpp_class = 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; - - (* Include the real header file for the super class *) - (match class_def.cl_super with - | Some super -> - let klass = fst super in - let include_files = get_all_meta_string_path klass.cl_meta Meta.Include in - if List.length include_files > 0 then - List.iter - (fun inc -> h_file#add_include (path_of_string inc)) - include_files - else h_file#add_include klass.cl_path - | _ -> ()); - - (* And any interfaces ... *) - List.iter - (fun imp -> - let interface = fst imp in - let include_files = - get_all_meta_string_path interface.cl_meta Meta.Include - in - if List.length include_files > 0 then - List.iter - (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); - - (* 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 class_def) None - ctx.ctx_super_deps CppContext.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"; + gen_class_header ctx tcpp_class h_file scriptable [ (Printf.sprintf "public %s" parent) ]; - output_h (get_class_code class_def Meta.HeaderCode); - let includes = - get_all_meta_string_path class_def.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); - - let extern_class = Common.defined common_ctx Define.DllExport in - let attribs = - "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" - in - - 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 initial = if super = "" then [] else [ (Printf.sprintf "public %s" parent) ] in - let all_parents = - class_def.cl_implements - |> List.fold_left folder initial - |> 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 class_name parent_string |> output_h; Printf.sprintf "\t\ttypedef %s super;\n" super |> output_h; Printf.sprintf "\t\ttypedef %s OBJ_;\n" class_name |> output_h; @@ -585,49 +521,6 @@ let generate_managed_header base_ctx tcpp_class = if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - let filter_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None in - - let filter_dynamic_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method MethDynamic, Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None in - - let filter_abstract_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_type) with - | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> - Some (field, tl, tr) - | _ -> - None - else - None in - - let filter_variables field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Var _, _ -> - Some field - (* Below should cause abstracts which have functions with no implementation to be generated as a field *) - | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> - Some field - | _ -> - None - else - None in - class_def.cl_ordered_statics |> List.filter_map filter_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); From e35bb2e2026f980ca9f88449c7817d10c9ea9d0b Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 25 Oct 2024 22:34:03 +0100 Subject: [PATCH 23/97] break class impl field gen function down --- src/generators/cpp/gen/cppGenClassHeader.ml | 3 + .../cpp/gen/cppGenClassImplementation.ml | 283 +++++++++--------- 2 files changed, 147 insertions(+), 139 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 6e855ba23cf..1589b2f4adc 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -108,6 +108,9 @@ let gen_dynamic_function ctx class_def is_static field function_def = Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix remap_name remap_name |> output let gen_abstract_function ctx class_def field tl tr = + + (* Default values for abstract classes are stored in @:Value metadata *) + (* So we need to inspect that to see which, if any, arguments of an abstract function have default values *) let ctx_arg_list ctx arg_list prefix = let get_default_value name = try diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 3e7265da63d..f171697312c 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -12,6 +12,146 @@ open CppSourceWriter open CppContext open CppGen +let gen_function ctx class_def class_name is_static field function_def = + let output = ctx.ctx_output in + let nargs = string_of_int (List.length function_def.tf_args) in + let return_type_str = type_to_string function_def.tf_type in + let return_type = cpp_type_of function_def.tf_type in + let no_debug = Meta.has Meta.NoDebug field.cf_meta 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 + + (* 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 initial = if is_static then [] else [ "::hx::Object *obj" ] in + + initial + |> List.append (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 (class_name ^ "::" ^ remap_name ^ "(") + else + output + ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" + ^ remap_name ^ "("); + + let cast_prefix arg = + match arg with + | TCppStar (t, const) -> + Printf.sprintf "(::cpp::%sPointer< %s >)" (if const then "Const" else "") (tcpp_to_string arg) + | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta -> + Printf.sprintf "(::cpp::Struct< %s >)" (tcpp_to_string arg) + | _ -> + "" in + tcpp_args + |> List.map cast_prefix + |> List.map2 + (fun prefix arg -> prefix ^ arg) + (List.init (List.length tcpp_args) (fun idx -> Printf.sprintf "a%i" idx)) + |> 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 + ("::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 + let prefix = if is_static then "STATIC_" else "" in + Printf.sprintf "%sHX_DEFINE_DYNAMIC_FUNC%s(%s, %s, %s)\n\n" prefix nargs class_name remap_name ret |> output + +let gen_dynamic_function ctx class_def class_name is_static field function_def = + let output = ctx.ctx_output in + let remap_name = keyword_remap field.cf_name in + let func_name = "__default_" ^ remap_name in + let nargs = string_of_int (List.length function_def.tf_args) in + let return_type_str = type_to_string function_def.tf_type in + let return_type = cpp_type_of function_def.tf_type in + let no_debug = Meta.has Meta.NoDebug field.cf_meta in + let is_void = return_type = TCppVoid in + let ret = if is_void then "(void)" else "return " 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 function_def.tf_args "__o_") |> output; + + gen_cpp_function_body ctx class_def is_static func_name function_def "" "" no_debug; + + output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); + output "HX_END_DEFAULT_FUNC\n\n"; + + if is_static then + output ("::Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") + let gen_field ctx class_def class_name is_static field = ctx.ctx_real_this_ptr <- not is_static; @@ -22,145 +162,10 @@ let gen_field ctx class_def class_name is_static field = 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; - - output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); - output "HX_END_DEFAULT_FUNC\n\n"; - - if is_static then - output ("::Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n")); - ctx.ctx_debug_level <- orig_debug + if not (is_dynamic_haxe_method field) then + gen_function ctx class_def class_name is_static field function_def + else + gen_dynamic_function ctx class_def class_name is_static field function_def; (* Data field *) | _ when has_decl -> if is_static then ( From 3bd3028bbc65150c03730afbe355d75f7db58c2e Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 25 Oct 2024 23:08:45 +0100 Subject: [PATCH 24/97] add converted fields to tcpp_class --- src/generators/cpp/cppAst.ml | 17 +- src/generators/cpp/cppRetyper.ml | 20 +-- src/generators/cpp/gen/cppGenClassHeader.ml | 100 ++--------- .../cpp/gen/cppGenClassImplementation.ml | 14 +- src/generators/gencpp.ml | 163 +++++++++++++++--- 5 files changed, 169 insertions(+), 145 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index ba1078211a3..1e6bbf8f27d 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -170,16 +170,17 @@ and tcpp_class = { cl_flags : int; cl_debug_level : int; - (* cl_static_variables : tclass_field list; - cl_static_properties : tclass_field list; - cl_static_functions : tclass_field list; - cb_static_dynamic_functions : tclass_field list; + cl_haxe_parents : (string, tclass) Hashtbl.t; + cl_native_parents : (string, tclass) Hashtbl.t; + + cl_static_variables : tclass_field list; + cl_static_functions : (tclass_field * tfunc) list; + cl_static_dynamic_functions : (tclass_field * tfunc) list; cl_variables : tclass_field list; - cl_properties : tclass_field list; - cl_functions : tclass_field list; - cb_dynamic_functions : tclass_field list; - cl_abstracts : tclass_field list; *) + cl_functions : (tclass_field * tfunc) list; + cl_dynamic_functions : (tclass_field * tfunc) list; + cl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; } and tcpp_interface = { diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index dadc1d805f6..9436657e5fc 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1431,22 +1431,4 @@ let expression ctx request_type function_args function_type expression_tree forI mk_cppexpr (CppCastScalar (cppExpr, too)) return_type | _ -> cppExpr in - retype request_type expression_tree - -(* let remap_to_class class_def = - let get_all_paths cls = - match CppStrings.get_all_meta_string_path cls.cl_meta Meta.Include with - | [] -> [ class_def.cl_path ] - | files -> List.map CppStrings.path_of_string files in - - let parent_includes = - match class_def.cl_super with - | Some (klass, _) -> get_all_paths klass - | _ -> [] in - - let implements_includes = - class_def.cl_implements - |> CppGen.real_interfaces - |> List.map (fun (interface, _) -> get_all_paths interface) - |> List.flatten in - () *) \ No newline at end of file + retype request_type expression_tree \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 1589b2f4adc..e1a12a66e27 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -12,49 +12,6 @@ open CppSourceWriter open CppContext open CppGen -let filter_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None - -let filter_dynamic_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method MethDynamic, Some { eexpr = TFunction func } -> - Some (field, func) - | _ -> - None - else - None - -let filter_abstract_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_type) with - | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> - Some (field, tl, tr) - | _ -> - None - else - None - -let filter_variables field = - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Var _, _ -> - Some field - (* Below should cause abstracts which have functions with no implementation to be generated as a field *) - | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> - Some field - | _ -> - None - else - None - let gen_member_variable ctx class_def is_static field = let tcpp = cpp_type_of field.cf_type in let tcpp_str = tcpp_to_string tcpp in @@ -273,34 +230,25 @@ let generate_native_header base_ctx tcpp_class = if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - class_def.cl_ordered_statics - |> List.filter_map filter_functions + tcpp_class.cl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); - class_def.cl_ordered_statics - |> List.filter_map filter_dynamic_functions + tcpp_class.cl_static_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); - class_def.cl_ordered_statics - |> List.filter_map filter_variables + tcpp_class.cl_static_variables |> List.iter (fun field -> gen_member_variable ctx class_def true field); - (* *) - - class_def.cl_ordered_fields - |> List.filter_map filter_functions + tcpp_class.cl_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); - class_def.cl_ordered_fields - |> List.filter_map filter_dynamic_functions + tcpp_class.cl_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); - class_def.cl_ordered_fields - |> List.filter_map filter_variables + tcpp_class.cl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - class_def.cl_ordered_fields - |> List.filter_map filter_abstract_functions + tcpp_class.cl_abstract_functions |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); output_h (get_class_code class_def Meta.HeaderClassCode); @@ -425,11 +373,8 @@ let generate_managed_header base_ctx tcpp_class = 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 + let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in + let implements_native = Hashtbl.length tcpp_class.cl_native_parents > 0 in if implements_native then ( let implemented_instance_fields = @@ -439,7 +384,7 @@ let generate_managed_header base_ctx tcpp_class = match implements_native with | true -> CppGen.needed_interface_functions implemented_instance_fields - native_implementations + tcpp_class.cl_native_parents | false -> [] in @@ -515,7 +460,7 @@ let generate_managed_header base_ctx tcpp_class = List.iter check_field interface.cl_ordered_fields in check_interface src) - haxe_implementations); + tcpp_class.cl_haxe_parents); if has_init_field class_def then output_h "\t\tstatic void __init__();\n\n"; output_h @@ -524,34 +469,25 @@ let generate_managed_header base_ctx tcpp_class = if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - class_def.cl_ordered_statics - |> List.filter_map filter_functions + tcpp_class.cl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); - class_def.cl_ordered_statics - |> List.filter_map filter_dynamic_functions + tcpp_class.cl_static_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); - class_def.cl_ordered_statics - |> List.filter_map filter_variables + tcpp_class.cl_static_variables |> List.iter (fun field -> gen_member_variable ctx class_def true field); - (* *) - - class_def.cl_ordered_fields - |> List.filter_map filter_functions + tcpp_class.cl_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); - class_def.cl_ordered_fields - |> List.filter_map filter_dynamic_functions + tcpp_class.cl_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); - class_def.cl_ordered_fields - |> List.filter_map filter_variables + tcpp_class.cl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - class_def.cl_ordered_fields - |> List.filter_map filter_abstract_functions + tcpp_class.cl_abstract_functions |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); output_h (get_class_code class_def Meta.HeaderClassCode); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index f171697312c..912c40d22a5 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -265,10 +265,6 @@ let generate base_ctx tcpp_class = |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) |> String.concat "," in - let haxe_implementations, native_implementations = - implementations class_def - in - if (not nativeGen) then ( output_cpp ("void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")"); @@ -333,8 +329,8 @@ let generate base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - let implements_haxe_keys = hash_keys haxe_implementations in - let implements_haxe = Hashtbl.length haxe_implementations > 0 in + let implements_haxe_keys = hash_keys tcpp_class.cl_haxe_parents in + let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in if implements_haxe then ( let alreadyGlued = Hashtbl.create 0 in @@ -344,7 +340,7 @@ let generate base_ctx tcpp_class = List.iter (fun interface_name -> try - let interface = Hashtbl.find haxe_implementations interface_name in + let interface = Hashtbl.find tcpp_class.cl_haxe_parents interface_name in output_cpp ("static " ^ cpp_class_name interface ^ " " ^ cname ^ "_" ^ interface_name ^ "= {\n"); @@ -416,7 +412,7 @@ let generate base_ctx tcpp_class = List.iter (fun interface_name -> try - let interface = Hashtbl.find haxe_implementations interface_name in + let interface = Hashtbl.find tcpp_class.cl_haxe_parents interface_name in output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ interface_name ^ ";\n") @@ -1154,7 +1150,7 @@ let generate base_ctx tcpp_class = ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," ^ join_class_path_remap intf_def.cl_path "::" ^ ");\n")) - native_implementations; + tcpp_class.cl_native_parents; output_cpp "}\n\n") else if not nativeGen then ( output_cpp ("::hx::Class " ^ class_name ^ "::__mClass;\n\n"); diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index fe0a3cf87cf..ca018e7b64b 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -241,6 +241,141 @@ let is_assign_op op = | OpAssign | OpAssignOp _ -> true | _ -> false + +let remap_to_class ctx self_id parent_ids class_def = + let filter_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None + in + + let filter_dynamic_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some (field, func) + | _ -> + None + else + None + in + + let filter_abstract_functions field = + if should_implement_field field then + match (field.cf_kind, field.cf_type) with + | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> + Some (field, tl, tr) + | _ -> + None + else + None + in + + let filter_variables field = + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Var _, _ -> + Some field + (* Below should cause abstracts which have functions with no implementation to be generated as a field *) + | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> + Some field + | _ -> + None + else + None + in + + let flags = + if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then + set_flag 0 (int_of_tcpp_class_flag Scriptable) + else + 0 + in + let flags = + if CppGen.can_quick_alloc class_def then + set_flag flags (int_of_tcpp_class_flag QuickAlloc) + else + flags + in + let flags = + if CppGen.has_gc_references class_def then + set_flag flags (int_of_tcpp_class_flag Container) + else + flags + in + + let static_functions = + class_def.cl_ordered_statics + |> List.filter_map filter_functions in + + let static_dynamic_functions = + class_def.cl_ordered_statics + |> List.filter_map filter_dynamic_functions in + + let static_variables = + class_def.cl_ordered_statics + |> List.filter_map filter_variables in + + let functions = + class_def.cl_ordered_fields + |> List.filter_map filter_functions in + + let dynamic_functions = + class_def.cl_ordered_fields + |> List.filter_map filter_dynamic_functions in + + let variables = + class_def.cl_ordered_fields + |> List.filter_map filter_variables in + + let abstract_functions = + class_def.cl_ordered_fields + |> List.filter_map filter_abstract_functions in + + let haxe_implementations, native_implementations = + CppGen.implementations class_def + in + + { + cl_class = class_def; + cl_id = self_id; + cl_name = class_name class_def; + cl_flags = flags; + cl_parent_ids = parent_ids; + cl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; + cl_static_variables = static_variables; + cl_static_functions = static_functions; + cl_static_dynamic_functions = static_dynamic_functions; + cl_variables = variables; + cl_functions = functions; + cl_dynamic_functions = dynamic_functions; + cl_abstract_functions = abstract_functions; + cl_haxe_parents = haxe_implementations; + cl_native_parents = native_implementations; + } + + (* let get_all_paths cls = + match CppStrings.get_all_meta_string_path cls.cl_meta Meta.Include with + | [] -> [ class_def.cl_path ] + | files -> List.map CppStrings.path_of_string files in + + let parent_includes = + match class_def.cl_super with + | Some (klass, _) -> get_all_paths klass + | _ -> [] in + + let implements_includes = + class_def.cl_implements + |> CppGen.real_interfaces + |> List.map (fun (interface, _) -> get_all_paths interface) + |> List.flatten in + () *) + (* The common_ctx contains the haxe AST in the "types" field and the resources *) @@ -364,33 +499,7 @@ let generate_source ctx = } in if native_gen then (NativeInterface iface) else (ManagedInterface iface) | false -> - let flags = - if Common.defined common_ctx Define.Scriptable && not class_def.cl_private then - set_flag 0 (int_of_tcpp_class_flag Scriptable) - else - 0 - in - let flags = - if CppGen.can_quick_alloc class_def then - set_flag flags (int_of_tcpp_class_flag QuickAlloc) - else - flags - in - let flags = - if CppGen.has_gc_references class_def then - set_flag flags (int_of_tcpp_class_flag Container) - else - flags - in - - let cls = { - cl_class = class_def; - cl_id = self_id; - cl_name = class_name class_def; - cl_flags = flags; - cl_parent_ids = parent_ids; - cl_debug_level = debug_level; - } in + let cls = remap_to_class ctx self_id parent_ids class_def in if native_gen then (NativeClass cls) else (ManagedClass cls) in let acc_decls = decl :: acc.decls in From 758a507ae4d87215fd619f18ea5ae7e8e18141f4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 26 Oct 2024 20:50:57 +0100 Subject: [PATCH 25/97] Initial split for managed and native class impl --- .../cpp/gen/cppGenClassImplementation.ml | 1206 +++++++++-------- src/generators/gencpp.ml | 4 +- 2 files changed, 630 insertions(+), 580 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 912c40d22a5..79506db6976 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -212,7 +212,107 @@ let gen_field_init ctx class_def field = gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr | _ -> () -let generate base_ctx tcpp_class = +let generate_native_class base_ctx tcpp_class = + let class_def = tcpp_class.cl_class in + let class_path = class_def.cl_path in + let debug = tcpp_class.cl_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 + + if debug > 1 then + print_endline + ("Found class definition:" ^ join_class_path class_def.cl_path "::"); + + 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 (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.cl_name in + + (match TClass.get_cl_init class_def with + | Some expression -> + let ctx = file_context base_ctx 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 statics_except_meta = statics_except_meta class_def in + + 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"); + + generate_native_constructor ctx output_cpp class_def false; + + if has_boot_field class_def then ( + output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); + + List.iter + (gen_field_init ctx class_def) + (List.filter should_implement_field class_def.cl_ordered_statics); + + output_cpp "}\n\n"); + + 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.cl_class in let class_path = class_def.cl_path in @@ -256,7 +356,6 @@ let generate base_ctx tcpp_class = output_cpp (get_class_code class_def Meta.CppNamespaceCode); - let nativeGen = Meta.has Meta.NativeGen class_def.cl_meta in let class_name = tcpp_class.cl_name in let cargs = constructor_arg_var_list class_def in let constructor_var_list = List.map snd cargs in @@ -265,170 +364,156 @@ let generate base_ctx tcpp_class = |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) |> String.concat "," in - if (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) - 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 - output_cpp - ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " - ^ class_name ^ "; }\n\n"); - output_cpp ("void *" ^ class_name ^ "::_hx_vtable = 0;\n\n"); + Printf.sprintf "::Dynamic %s::__CreateEmpty() { return new %s; }\n\n" class_name class_name |> output_cpp; - 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"); - - output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); - let implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.cl_id :: tcpp_class.cl_parent_ids) 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"; + Printf.sprintf "void* %s::_hx_vtable = 0;\n\n" class_name |> output_cpp; - let implements_haxe_keys = hash_keys tcpp_class.cl_haxe_parents in - let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in + 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"); - 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 tcpp_class.cl_haxe_parents 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 + output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); + let implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.cl_id :: tcpp_class.cl_parent_ids) 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"; + + let implements_haxe_keys = hash_keys tcpp_class.cl_haxe_parents in + let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in + + 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 tcpp_class.cl_haxe_parents 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 castKey <> implementationKey then ( - let glue = - Printf.sprintf "%s_%08lx" field.cf_name - (gen_hash32 0 cast) + 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 - 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 + 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 - gen_interface_funcs interface; - output_cpp "};\n\n" - with Not_found -> ()) - implements_haxe_keys; + (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 (String.concat "\n" !cpp_glue); + output_cpp (String.concat "\n" !cpp_glue); - 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 tcpp_class.cl_haxe_parents 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")); + 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 tcpp_class.cl_haxe_parents 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 -> @@ -484,10 +569,8 @@ let generate base_ctx tcpp_class = let inline_constructor = can_inline_constructor base_ctx class_def in - if (not nativeGen) && (not inline_constructor)&& not (has_class_flag class_def CAbstract) then - generate_constructor ctx output_cpp tcpp_class false - else if nativeGen then - generate_native_constructor ctx output_cpp class_def false; + if (not inline_constructor)&& not (has_class_flag class_def CAbstract) then + generate_constructor ctx output_cpp tcpp_class false; let reflect_member_fields = List.filter (reflective class_def) class_def.cl_ordered_fields @@ -497,336 +580,332 @@ let generate base_ctx tcpp_class = in (* Initialise non-static variables *) - if (not nativeGen) then ( - output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); + 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") + | _ -> ()) + in + + let implemented_instance_fields = + List.filter should_implement_field class_def.cl_ordered_fields + in + + if has_new_gc_references class_def 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 - (fun name -> - output_cpp ("\t" ^ name ^ " = new __default_" ^ name ^ "(this);\n")) - dynamic_functions; + (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"; - 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") - | _ -> ()) - in + (* 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") + implemented_instance_fields; + (match super_needs_iteration with + | "" -> () + | super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n")); + output_cpp "}\n\n"); - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields - in + 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 + + let checkPropCall field = + if + Meta.has Meta.NativeProperty class_def.cl_meta + || Meta.has Meta.NativeProperty field.cf_meta + || Common.defined common_ctx Define.ForceNativeProperty + then "inCallProp != ::hx::paccNever" + else "inCallProp == ::hx::paccAlways" + in - let override_iteration = - (not nativeGen) && has_new_gc_references class_def + 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) + ^ " )" + 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 - 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"); - 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") + let reflect_member_readable = + List.filter (is_readable class_def) reflect_member_fields in + dump_quick_field_test (get_field_dat reflect_member_readable); + output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); - let checkPropCall field = - if - Meta.has Meta.NativeProperty class_def.cl_meta - || Meta.has Meta.NativeProperty field.cf_meta - || Common.defined common_ctx Define.ForceNativeProperty - then "inCallProp != ::hx::paccNever" - else "inCallProp == ::hx::paccAlways" + 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 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 reflect_static_readable = + List.filter (is_readable class_def) reflect_static_fields 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); - 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"); + 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 - 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 + (* 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 - (* 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 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"); - - 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 - - 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"); + 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"); - (* 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 + 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 - 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 ^ " */ " + let reflect_static_writable = + List.filter (is_writable class_def) reflect_static_fields 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") + let reflect_write_static_variables = + List.filter variable_field reflect_static_writable in - let dump_static_storage field = - output_cpp - ("\t{" ^ storage field ^ ",(void *) &" ^ class_name ^ "::" - ^ keyword_remap field.cf_name - ^ "," ^ strq field.cf_name ^ "},\n") + dump_quick_field_test (set_field_dat reflect_write_static_variables); + output_cpp "\treturn false;\n}\n\n"); + + (* 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 - output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; + 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") + in + let dump_static_storage field = + output_cpp + ("\t{" ^ storage field ^ ",(void *) &" ^ class_name ^ "::" + ^ keyword_remap field.cf_name + ^ "," ^ strq field.cf_name ^ "},\n") + in - let stored_fields = - List.filter is_data_member implemented_instance_fields - 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"); + output_cpp "#ifdef HXCPP_SCRIPTABLE\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 stored_fields = + List.filter is_data_member implemented_instance_fields + 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"); - output_cpp "#endif\n\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"); + + output_cpp "#endif\n\n"; (* cl_interface *) let implemented_instance_fields = @@ -846,9 +925,7 @@ let generate base_ctx tcpp_class = memberFields in - let hasMarkFunc = - (not nativeGen) && List.exists is_data_member implemented_fields - in + let hasMarkFunc = List.exists is_data_member implemented_fields in if hasMarkFunc then ( (* Mark static variables as used *) @@ -932,7 +1009,7 @@ let generate base_ctx tcpp_class = | _ -> "" in - if scriptable && not nativeGen then ( + if scriptable then ( 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 @@ -1069,115 +1146,88 @@ let generate base_ctx tcpp_class = let class_name_text = join_class_path class_path "." in (* Initialise static in boot function ... *) - if (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 + (* 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")); - 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")) - tcpp_class.cl_native_parents; - 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"); + 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 - ("\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"); + Hashtbl.iter + (fun _ intf_def -> output_cpp - (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," - ^ class_name ^ ");\n"); - output_cpp "}\n\n"); + ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," + ^ join_class_path_remap intf_def.cl_path "::" + ^ ");\n")) + tcpp_class.cl_native_parents; + output_cpp "}\n\n"; if has_boot_field class_def then ( output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index ca018e7b64b..a22558762a5 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -541,10 +541,10 @@ let generate_source ctx = match tcpp_type with | ManagedClass tcpp_class -> CppGenClassHeader.generate_managed_header ctx tcpp_class; - CppGenClassImplementation.generate ctx tcpp_class; + CppGenClassImplementation.generate_managed_class ctx tcpp_class; | NativeClass tcpp_class -> CppGenClassHeader.generate_native_header ctx tcpp_class; - CppGenClassImplementation.generate 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; From 057d790e7cec3da266f6fa47322bd988ee90fb59 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 26 Oct 2024 22:23:52 +0100 Subject: [PATCH 26/97] map for haxe and native implementations --- src/generators/cpp/cppAst.ml | 6 +- src/generators/cpp/cppAstTools.ml | 5 +- src/generators/cpp/cppContext.ml | 6 +- src/generators/cpp/gen/cppGen.ml | 49 +++--- src/generators/cpp/gen/cppGenClassHeader.ml | 25 +-- .../cpp/gen/cppGenClassImplementation.ml | 149 +++++++++--------- src/generators/cpp/gen/cppGenEnum.ml | 2 +- .../cpp/gen/cppGenInterfaceHeader.ml | 2 +- src/generators/cpp/gen/cppReferences.ml | 6 +- src/generators/gencpp.ml | 20 +-- 10 files changed, 129 insertions(+), 141 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 1e6bbf8f27d..c3123982334 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -5,6 +5,8 @@ open Error open Common 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) + type tcpp = | TCppDynamic | TCppUnchanged @@ -170,8 +172,8 @@ and tcpp_class = { cl_flags : int; cl_debug_level : int; - cl_haxe_parents : (string, tclass) Hashtbl.t; - cl_native_parents : (string, tclass) Hashtbl.t; + cl_haxe_parents : tclass PathMap.t; + cl_native_parents : tclass PathMap.t; cl_static_variables : tclass_field list; cl_static_functions : (tclass_field * tfunc) list; diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 732640303cd..c4415836a03 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -733,4 +733,7 @@ let int_of_tcpp_class_flag (flag:tcpp_class_flags) = Obj.magic flag let has_tcpp_class_flag c flag = - has_flag c.cl_flags (int_of_tcpp_class_flag flag) \ No newline at end of file + has_flag c.cl_flags (int_of_tcpp_class_flag flag) + +let cpp_interface_impl_name interface = + "_hx_" ^ join_class_path interface.cl_path "_" \ No newline at end of file diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index 94b1671d509..da7614b3025 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -6,8 +6,6 @@ open Common open Globals open CppAstTools -module PathMap = Map.Make(struct type t = path let compare i1 i2 = String.compare (s_type_path i2) (s_type_path i1) end) - (* CPP code generation context *) (* ctx_debug_level @@ -31,8 +29,8 @@ type context = { ctx_is_header : bool; ctx_interface_slot : (string, int) Hashtbl.t ref; ctx_interface_slot_count : int ref; - ctx_super_deps : path list PathMap.t; - ctx_constructor_deps : tclass_field PathMap.t; + 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; diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 74669b1825c..a50d42606a8 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -498,41 +498,30 @@ let gen_gc_name class_path = (* 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 rec folder (haxe, native) (interface, _) = + let acc = if is_native_class interface then + List.fold_left folder (haxe, PathMap.add interface.cl_path interface native) interface.cl_implements + else + List.fold_left folder (PathMap.add interface.cl_path interface haxe, native) interface.cl_implements in - let cpp_interface_impl_name interface = - "_hx_" ^ join_class_path interface.cl_path "_" - 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 + match interface.cl_super with + | Some super -> folder acc super + | None -> acc in - List.iter iterator (real_interfaces class_def.cl_implements); - (implemented_hash, native_implemented) + class_def.cl_implements + |> real_interfaces + |> List.fold_left folder (PathMap.empty, PathMap.empty) -let needed_interface_functions implemented_instance_fields - native_implementations = +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 + implemented_instance_fields + |> List.map (fun field -> (field.cf_name, ())) + |> List.to_seq + |> Hashtbl.of_seq in let want = ref [] in - Hashtbl.iter + PathMap.iter (fun _ intf_def -> List.iter (fun field -> @@ -1654,11 +1643,11 @@ let generate_main ctx super_deps class_def = | _ -> die "" __LOC__ in CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps - CppContext.PathMap.empty false false false + PathMap.empty false false false |> ignore; let depend_referenced = CppReferences.find_referenced_types ctx (TClassDecl class_def) super_deps - CppContext.PathMap.empty false true false + PathMap.empty false true false in let generate_startup filename is_main = (*make_class_directories base_dir ( "src" :: []);*) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index e1a12a66e27..b64e21ddd1c 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -163,7 +163,7 @@ let gen_class_header ctx tcpp_class h_file scriptable parents = let class_path = tcpp_class.cl_class.cl_path in let header_referenced, header_flags = CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_class.cl_class) None - ctx.ctx_super_deps CppContext.PathMap.empty true false scriptable + ctx.ctx_super_deps PathMap.empty true false scriptable in List.iter2 (fun r f -> gen_forward_decl h_file r f) @@ -373,8 +373,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in - let implements_native = Hashtbl.length tcpp_class.cl_native_parents > 0 in + let implements_haxe = PathMap.cardinal tcpp_class.cl_haxe_parents > 0 in + let implements_native = PathMap.cardinal tcpp_class.cl_native_parents > 0 in if implements_native then ( let implemented_instance_fields = @@ -383,9 +383,9 @@ let generate_managed_header base_ctx tcpp_class = let neededInterfaceFunctions = match implements_native with | true -> - CppGen.needed_interface_functions implemented_instance_fields - tcpp_class.cl_native_parents - | false -> [] + CppGen.needed_interface_functions implemented_instance_fields tcpp_class.cl_native_parents + | false -> + [] in output_h "\n\t\tHX_NATIVE_IMPLEMENTATION\n"; @@ -416,8 +416,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid *_hx_getInterface(int inHash);\n"; (* generate header glue *) let alreadyGlued = Hashtbl.create 0 in - Hashtbl.iter - (fun interface_name src -> + PathMap.iter + (fun _ src -> let rec check_interface interface = let check_field field = match (follow field.cf_type, field.cf_kind) with @@ -429,10 +429,11 @@ let generate_managed_header base_ctx tcpp_class = 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 + let castKey = match interface.cl_path with + | ([ "haxe" ], "IMap") when realName = "set" -> + castKey ^ "*" + | _ -> + castKey in let implementationKey = realName ^ "::" ^ class_implementation diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 79506db6976..3f6c10a7a20 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -414,95 +414,90 @@ let generate_managed_class base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - let implements_haxe_keys = hash_keys tcpp_class.cl_haxe_parents in - let implements_haxe = Hashtbl.length tcpp_class.cl_haxe_parents > 0 in + let implements_haxe = PathMap.cardinal tcpp_class.cl_haxe_parents > 0 in 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 tcpp_class.cl_haxe_parents 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 + let iter _ interface = + let interface_name = cpp_interface_impl_name interface 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 implementationKey = - realName ^ "::" ^ class_implementation + let cppCode = + returnType ^ " " ^ class_name ^ "::" ^ glue ^ "(" + ^ argList ^ ") {\n" ^ "\t\t\t" ^ returnStr ^ realName + ^ "(" ^ print_arg_names args ^ ");\n}\n" 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; + (* 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" in + PathMap.iter + iter + tcpp_class.cl_haxe_parents; output_cpp (String.concat "\n" !cpp_glue); 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 tcpp_class.cl_haxe_parents interface_name in - output_cpp - ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" - ^ cname ^ "_" ^ interface_name ^ ";\n") - with Not_found -> ()) - implements_haxe_keys; + + let iter _ interface = + output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface ^ ";\n") in + PathMap.iter + iter + tcpp_class.cl_haxe_parents; output_cpp "\t}\n"; @@ -1220,7 +1215,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp (" HX_SCRIPTABLE_REGISTER_CLASS(\"" ^ class_name_text ^ "\"," ^ class_name ^ ");\n"); - Hashtbl.iter + PathMap.iter (fun _ intf_def -> output_cpp ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 0ff43a2f3eb..1f1ce35d92f 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -60,7 +60,7 @@ let generate base_ctx tcpp_enum = cpp_file#write_h "#include \n\n"; - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl tcpp_enum.e_enum) None ctx.ctx_super_deps CppContext.PathMap.empty false false false in + let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl tcpp_enum.e_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; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 548639bf5f4..d989ee8ce14 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -86,7 +86,7 @@ let gen_forward_decls h_file interface_def ctx common_ctx = (* Only need to forward-declare classes that are mentioned in the header file (ie, not the implementation) *) let scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps CppContext.PathMap.empty true false scriptable + CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps PathMap.empty true false scriptable in List.iter2 diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index f168e917f5f..6c9fa5b785f 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -29,7 +29,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade 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) (CppContext.PathMap.find in_path super_deps) + 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 = @@ -120,7 +120,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade | TNew (klass, params, _) -> ( visit_type (TInst (klass, params)); try - let construct_type = CppContext.PathMap.find klass.cl_path constructor_deps 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 ... *) @@ -140,7 +140,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade | TInst (klass, params) -> ( try let construct_type = - CppContext.PathMap.find klass.cl_path constructor_deps + PathMap.find klass.cl_path constructor_deps in visit_type construct_type.cf_type with Not_found -> ()) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a22558762a5..258659f2c5d 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -216,13 +216,13 @@ let create_super_dependencies common_ctx = (fun acc (cls, _) -> if has_class_flag cls CExtern then acc else cls.cl_path :: acc) initial in - CppContext.PathMap.add class_def.cl_path deps acc + PathMap.add class_def.cl_path deps acc | TEnumDecl enum_def when not (has_enum_flag enum_def EnExtern) -> - CppContext.PathMap.add enum_def.e_path [] acc + PathMap.add enum_def.e_path [] acc | _ -> acc in - List.fold_left folder CppContext.PathMap.empty common_ctx.types + List.fold_left folder PathMap.empty common_ctx.types let create_constructor_dependencies common_ctx = List.fold_left @@ -230,10 +230,10 @@ let create_constructor_dependencies common_ctx = match object_def with | TClassDecl class_def when not (has_class_flag class_def CExtern) -> (match class_def.cl_constructor with - | Some func -> CppContext.PathMap.add class_def.cl_path func acc + | Some func -> PathMap.add class_def.cl_path func acc | None -> acc) | _ -> acc) - CppContext.PathMap.empty + PathMap.empty common_ctx.types let is_assign_op op = @@ -381,15 +381,15 @@ let remap_to_class ctx self_id parent_ids class_def = *) module ObjectIds = struct - type t = (int32 CppContext.PathMap.t * unit Int32Map.t) + type t = (int32 PathMap.t * unit Int32Map.t) - let empty = (CppContext.PathMap.empty, Int32Map.empty) + let empty = (PathMap.empty, Int32Map.empty) let add path id ((ids, cache):t) = - (CppContext.PathMap.add path id ids, Int32Map.add id () cache) + (PathMap.add path id ids, Int32Map.add id () cache) let find_opt path ((ids, _):t) = - CppContext.PathMap.find_opt path ids + PathMap.find_opt path ids let collision id ((_, cache):t) = Int32Map.mem id cache @@ -522,7 +522,7 @@ let generate_source ctx = | TEnumDecl enum_def -> let self_id, all_ids = get_id enum_def.e_path acc.ids in - let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps CppContext.PathMap.empty false true false in + let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps PathMap.empty false true false in let strq = strq ctx.ctx_common in let sort_constructors f1 f2 = f1.ef_index - f2.ef_index in From d190014c089a435b7e1991b71fb360d70fbaabc2 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 26 Oct 2024 22:43:04 +0100 Subject: [PATCH 27/97] use a list for haxe and native implementations --- src/generators/cpp/cppAst.ml | 4 ++-- src/generators/cpp/gen/cppGen.ml | 7 +++++-- src/generators/cpp/gen/cppGenClassHeader.ml | 8 ++++---- .../cpp/gen/cppGenClassImplementation.ml | 14 +++++++------- 4 files changed, 18 insertions(+), 15 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index c3123982334..a7424335aa5 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -172,8 +172,8 @@ and tcpp_class = { cl_flags : int; cl_debug_level : int; - cl_haxe_parents : tclass PathMap.t; - cl_native_parents : tclass PathMap.t; + cl_haxe_parents : tclass list; + cl_native_parents : tclass list; cl_static_variables : tclass_field list; cl_static_functions : (tclass_field * tfunc) list; diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index a50d42606a8..1233f040f31 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -508,10 +508,13 @@ let implementations class_def = | Some super -> folder acc super | None -> acc in + let values (haxe, native) = + haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in class_def.cl_implements |> real_interfaces |> List.fold_left folder (PathMap.empty, PathMap.empty) + |> values let needed_interface_functions implemented_instance_fields native_implementations = let have = @@ -521,8 +524,8 @@ let needed_interface_functions implemented_instance_fields native_implementation |> Hashtbl.of_seq in let want = ref [] in - PathMap.iter - (fun _ intf_def -> + List.iter + (fun intf_def -> List.iter (fun field -> if not (Hashtbl.mem have field.cf_name) then ( diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index b64e21ddd1c..d715b173bc2 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -373,8 +373,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - let implements_haxe = PathMap.cardinal tcpp_class.cl_haxe_parents > 0 in - let implements_native = PathMap.cardinal tcpp_class.cl_native_parents > 0 in + let implements_haxe = List.length tcpp_class.cl_haxe_parents > 0 in + let implements_native = List.length tcpp_class.cl_native_parents > 0 in if implements_native then ( let implemented_instance_fields = @@ -416,8 +416,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid *_hx_getInterface(int inHash);\n"; (* generate header glue *) let alreadyGlued = Hashtbl.create 0 in - PathMap.iter - (fun _ src -> + List.iter + (fun src -> let rec check_interface interface = let check_field field = match (follow field.cf_type, field.cf_kind) with diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 3f6c10a7a20..0eb50199bea 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -414,14 +414,14 @@ let generate_managed_class base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - let implements_haxe = PathMap.cardinal tcpp_class.cl_haxe_parents > 0 in + let implements_haxe = List.length tcpp_class.cl_haxe_parents > 0 in 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 - let iter _ interface = + let iter interface = let interface_name = cpp_interface_impl_name interface in output_cpp ("static " ^ cpp_class_name interface ^ " " ^ cname ^ "_" @@ -484,7 +484,7 @@ let generate_managed_class base_ctx tcpp_class = in gen_interface_funcs interface; output_cpp "};\n\n" in - PathMap.iter + List.iter iter tcpp_class.cl_haxe_parents; @@ -493,9 +493,9 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("void *" ^ class_name ^ "::_hx_getInterface(int inHash) {\n"); output_cpp "\tswitch(inHash) {\n"; - let iter _ interface = + let iter interface = output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface ^ ";\n") in - PathMap.iter + List.iter iter tcpp_class.cl_haxe_parents; @@ -1215,8 +1215,8 @@ let generate_managed_class base_ctx tcpp_class = output_cpp (" HX_SCRIPTABLE_REGISTER_CLASS(\"" ^ class_name_text ^ "\"," ^ class_name ^ ");\n"); - PathMap.iter - (fun _ intf_def -> + List.iter + (fun intf_def -> output_cpp ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," ^ join_class_path_remap intf_def.cl_path "::" From 5d3a415b26385d333643bda1a5e529c66a6eefee Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 27 Oct 2024 18:41:36 +0000 Subject: [PATCH 28/97] use tcpp_class field variables --- src/generators/cpp/gen/cppGen.ml | 12 +- src/generators/cpp/gen/cppGenClassHeader.ml | 5 +- .../cpp/gen/cppGenClassImplementation.ml | 160 ++++++++---------- 3 files changed, 76 insertions(+), 101 deletions(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 1233f040f31..89cbd381eae 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1978,14 +1978,4 @@ let generate_native_constructor ctx out class_def isHeader = let tail_code = get_code definition.cf_meta Meta.FunctionTailCode in 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 \ No newline at end of file + | _ -> () \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index d715b173bc2..2917b59d74e 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -335,10 +335,9 @@ let generate_managed_header base_ctx tcpp_class = 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 + if List.length (tcpp_class.cl_dynamic_functions) > 0 then output_h - ("\t\tstatic void __alloc_dynamic_functions(::hx::Ctx *_hx_alloc," - ^ class_name ^ " *_hx_obj);\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"); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0eb50199bea..0f90910ec44 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -12,7 +12,7 @@ open CppSourceWriter open CppContext open CppGen -let gen_function ctx class_def class_name is_static field function_def = +let gen_function ctx class_def class_name is_static (field, function_def) = let output = ctx.ctx_output in let nargs = string_of_int (List.length function_def.tf_args) in let return_type_str = type_to_string function_def.tf_type in @@ -129,7 +129,7 @@ let gen_function ctx class_def class_name is_static field function_def = let prefix = if is_static then "STATIC_" else "" in Printf.sprintf "%sHX_DEFINE_DYNAMIC_FUNC%s(%s, %s, %s)\n\n" prefix nargs class_name remap_name ret |> output -let gen_dynamic_function ctx class_def class_name is_static field function_def = +let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (field, function_def) = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in let func_name = "__default_" ^ remap_name in @@ -149,45 +149,22 @@ let gen_dynamic_function ctx class_def class_name is_static field function_def = output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); output "HX_END_DEFAULT_FUNC\n\n"; - if is_static then + if is_static && not is_for_static_var then output ("::Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") -let gen_field ctx class_def class_name is_static field = - ctx.ctx_real_this_ptr <- not is_static; +let gen_static_variable ctx class_def class_name field = + let output = ctx.ctx_output in + let remap_name = keyword_remap field.cf_name in + gen_type ctx field.cf_type; + output (" " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") +let gen_abstract_function ctx class_def class_name (field, tl, tr) = 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 } -> - if not (is_dynamic_haxe_method field) then - gen_function ctx class_def class_name is_static field function_def - else - gen_dynamic_function ctx class_def class_name is_static field function_def; - (* 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 - ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," - ^ remap_name ^ "," ^ ret ^ ")\n\n") + 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 + Printf.sprintf "HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" (List.length tl) class_name remap_name ret |> output let gen_field_init ctx class_def field = let dot_name = join_class_path class_def.cl_path "." in @@ -259,43 +236,46 @@ let generate_native_class base_ctx tcpp_class = output_cpp "\n\n" | _ -> ()); - let statics_except_meta = statics_except_meta class_def in + List.iter (gen_function ctx class_def class_name false) tcpp_class.cl_functions; + List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.cl_dynamic_functions; + List.iter (gen_abstract_function ctx class_def class_name) tcpp_class.cl_abstract_functions; + + List.iter (gen_function ctx class_def class_name true) tcpp_class.cl_static_functions; + List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.cl_static_dynamic_functions; + List.iter (gen_static_variable ctx class_def class_name) tcpp_class.cl_static_variables; + + (* Generate a dynamic function for static variables with a default function *) + tcpp_class.cl_static_variables + |> List.filter_map (fun field -> match field.cf_expr with + | Some { eexpr = TFunction function_def } -> Some (field, function_def) + | _ -> None) + |> List.iter (gen_dynamic_function ctx class_def class_name true true); - 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"); + (match tcpp_class.cl_dynamic_functions with + | [] -> () + | functions -> ( + Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; List.iter - (fun name -> - output_cpp - ("\tif (!_hx_obj->" ^ name ^ ".mPtr) _hx_obj->" ^ name - ^ " = new __default_" ^ name ^ "(_hx_obj);\n")) - dynamic_functions; + (fun (field, _) -> + let name = keyword_remap field.cf_name in + Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }\n" name name name |> output_cpp) + functions; (match class_def.cl_super with - | Some super -> + | 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") + 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) + | Some (super, _) -> find_super super | _ -> () in - find_super (fst super) + find_super super | _ -> ()); - output_cpp "}\n"); + output_cpp "}\n")); generate_native_constructor ctx output_cpp class_def false; @@ -525,41 +505,46 @@ let generate_managed_class base_ctx tcpp_class = List.filter should_implement_field statics_except_meta in - 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; + List.iter (gen_function ctx class_def class_name false) tcpp_class.cl_functions; + List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.cl_dynamic_functions; + List.iter (gen_abstract_function ctx class_def class_name) tcpp_class.cl_abstract_functions; + + List.iter (gen_function ctx class_def class_name true) tcpp_class.cl_static_functions; + List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.cl_static_dynamic_functions; + List.iter (gen_static_variable ctx class_def class_name) tcpp_class.cl_static_variables; + + (* Generate a dynamic function for static variables with a default function *) + tcpp_class.cl_static_variables + |> List.filter_map (fun field -> match field.cf_expr with + | Some { eexpr = TFunction function_def } -> Some (field, function_def) + | _ -> None) + |> List.iter (gen_dynamic_function ctx class_def class_name true true); + 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"); + (match tcpp_class.cl_dynamic_functions with + | [] -> () + | functions -> ( + Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; List.iter - (fun name -> - output_cpp - ("\tif (!_hx_obj->" ^ name ^ ".mPtr) _hx_obj->" ^ name - ^ " = new __default_" ^ name ^ "(_hx_obj);\n")) - dynamic_functions; + (fun (field, _) -> + let name = keyword_remap field.cf_name in + Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }\n" name name name |> output_cpp) + functions; (match class_def.cl_super with - | Some super -> + | 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") + 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) + | Some (super, _) -> find_super super | _ -> () in - find_super (fst super) + find_super super | _ -> ()); - output_cpp "}\n"); + output_cpp "}\n")); let inline_constructor = can_inline_constructor base_ctx class_def @@ -577,9 +562,10 @@ let generate_managed_class base_ctx tcpp_class = (* Initialise non-static variables *) output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); List.iter - (fun name -> + (fun (field, _) -> + let name = keyword_remap field.cf_name in output_cpp ("\t" ^ name ^ " = new __default_" ^ name ^ "(this);\n")) - dynamic_functions; + tcpp_class.cl_dynamic_functions; output_cpp "}\n\n"; let dump_field_iterator macro field = From 9829bf296d423f35ae227320c21cf8624d2ee38d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 28 Oct 2024 20:08:42 +0000 Subject: [PATCH 29/97] field rename and meta / rtti filtering --- src/generators/cpp/cppAst.ml | 39 +++++----- src/generators/cpp/cppAstTools.ml | 2 +- src/generators/cpp/gen/cppGen.ml | 14 ++-- src/generators/cpp/gen/cppGenClassHeader.ml | 72 +++++++++---------- .../cpp/gen/cppGenClassImplementation.ml | 56 +++++++-------- src/generators/gencpp.ml | 45 +++++++----- 6 files changed, 120 insertions(+), 108 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index a7424335aa5..880182e10e8 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -165,24 +165,27 @@ and tcpp_class_flags = | Scriptable and tcpp_class = { - cl_class : tclass; - cl_name : string; - cl_id : int32; - cl_parent_ids : int32 list; - cl_flags : int; - cl_debug_level : int; - - cl_haxe_parents : tclass list; - cl_native_parents : tclass list; - - cl_static_variables : tclass_field list; - cl_static_functions : (tclass_field * tfunc) list; - cl_static_dynamic_functions : (tclass_field * tfunc) list; - - cl_variables : tclass_field list; - cl_functions : (tclass_field * tfunc) list; - cl_dynamic_functions : (tclass_field * tfunc) list; - cl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; + tcl_class : tclass; + tcl_name : string; + tcl_id : int32; + tcl_parent_ids : int32 list; + tcl_flags : int; + tcl_debug_level : int; + + tcl_haxe_parents : tclass list; + tcl_native_parents : tclass list; + + tcl_static_variables : tclass_field list; + tcl_static_functions : (tclass_field * tfunc) list; + tcl_static_dynamic_functions : (tclass_field * tfunc) list; + + tcl_variables : tclass_field list; + tcl_functions : (tclass_field * tfunc) list; + tcl_dynamic_functions : (tclass_field * tfunc) list; + tcl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; + + tcl_meta_field : tclass_field option; + tcl_rtti_field : tclass_field option; } and tcpp_interface = { diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index c4415836a03..7faf78b986f 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -733,7 +733,7 @@ let int_of_tcpp_class_flag (flag:tcpp_class_flags) = Obj.magic flag let has_tcpp_class_flag c flag = - has_flag c.cl_flags (int_of_tcpp_class_flag flag) + has_flag c.tcl_flags (int_of_tcpp_class_flag flag) let cpp_interface_impl_name interface = "_hx_" ^ join_class_path interface.cl_path "_" \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 89cbd381eae..c405b32211b 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1865,12 +1865,12 @@ let constructor_arg_var_list class_def = | _ -> [] let generate_constructor ctx out tcpp_class isHeader = - let class_name = tcpp_class.cl_name in - let ptr_name = class_pointer tcpp_class.cl_class in + 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.cl_class.cl_path in + let gcName = gen_gc_name tcpp_class.tcl_class.cl_path in let isContainer = if has_tcpp_class_flag tcpp_class Container then "true" else "false" in - let cargs = constructor_arg_var_list tcpp_class.cl_class 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) cargs) @@ -1909,16 +1909,16 @@ let generate_constructor ctx out tcpp_class isHeader = | Some super -> dump_dynamic (fst super) | _ -> () in - dump_dynamic tcpp_class.cl_class; + dump_dynamic tcpp_class.tcl_class; if isHeader then - match tcpp_class.cl_class.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 tcpp_class.cl_class false "new" function_def "" "" + gen_cpp_function_body ctx tcpp_class.tcl_class false "new" function_def "" "" no_debug; out "\n") | _ -> () diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 2917b59d74e..b26de1a4389 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -126,13 +126,13 @@ let gen_member_function ctx class_def is_static field function_def = Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix remap_name |> output let gen_class_header ctx tcpp_class h_file scriptable parents = - let class_path = tcpp_class.cl_class.cl_path in + 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 false; (* Include the real header file for the super class *) - (match tcpp_class.cl_class.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 @@ -155,14 +155,14 @@ let gen_class_header ctx tcpp_class h_file scriptable parents = (fun inc -> h_file#add_include (path_of_string inc)) include_files else h_file#add_include interface.cl_path) - (real_interfaces tcpp_class.cl_class.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 output_h = h_file#write in - let class_path = tcpp_class.cl_class.cl_path in + let class_path = tcpp_class.tcl_class.cl_path in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_class.cl_class) None + CppReferences.find_referenced_types_flags ctx (TClassDecl tcpp_class.tcl_class) None ctx.ctx_super_deps PathMap.empty true false scriptable in List.iter2 @@ -170,16 +170,16 @@ let gen_class_header ctx tcpp_class h_file scriptable parents = header_referenced header_flags; output_h "\n"; - output_h (get_class_code tcpp_class.cl_class Meta.HeaderCode); + output_h (get_class_code tcpp_class.tcl_class Meta.HeaderCode); let includes = - get_all_meta_string_path tcpp_class.cl_class.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 tcpp_class.cl_class Meta.HeaderNamespaceCode); + output_h (get_class_code tcpp_class.tcl_class Meta.HeaderNamespaceCode); let extern_class = Common.defined ctx.ctx_common Define.DllExport in let attribs = @@ -193,7 +193,7 @@ let gen_class_header ctx tcpp_class h_file scriptable parents = acc in let all_parents = - tcpp_class.cl_class.cl_implements + tcpp_class.tcl_class.cl_implements |> List.fold_left folder parents |> List.rev in let parent_string = @@ -201,16 +201,16 @@ let gen_class_header ctx tcpp_class h_file scriptable parents = | [] -> "" | xs -> " : " ^ String.concat ", " xs in - Printf.sprintf "class %s %s%s\n{\n\tpublic:\n" attribs tcpp_class.cl_name parent_string |> output_h + 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.cl_class 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.cl_debug_level true 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 @@ -230,25 +230,25 @@ let generate_native_header base_ctx tcpp_class = if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - tcpp_class.cl_static_functions + tcpp_class.tcl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); - tcpp_class.cl_static_dynamic_functions + tcpp_class.tcl_static_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); - tcpp_class.cl_static_variables + tcpp_class.tcl_static_variables |> List.iter (fun field -> gen_member_variable ctx class_def true field); - tcpp_class.cl_functions + tcpp_class.tcl_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); - tcpp_class.cl_dynamic_functions + tcpp_class.tcl_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); - tcpp_class.cl_variables + tcpp_class.tcl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - tcpp_class.cl_abstract_functions + tcpp_class.tcl_abstract_functions |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); output_h (get_class_code class_def Meta.HeaderClassCode); @@ -262,24 +262,24 @@ let generate_native_header base_ctx tcpp_class = let generate_managed_header base_ctx tcpp_class = let common_ctx = base_ctx.ctx_common in - let class_def = tcpp_class.cl_class 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.cl_name 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 isContainer = if has_tcpp_class_flag tcpp_class Container then "true" else "false" in let constructor_type_args = - tcpp_class.cl_class + 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.cl_debug_level true 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 = @@ -299,7 +299,7 @@ let generate_managed_header base_ctx tcpp_class = 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.cl_id in + let classIdTxt = Printf.sprintf "0x%08lx" tcpp_class.tcl_id in output_h ("\t\t" ^ class_name ^ "();\n"); output_h "\n\tpublic:\n"; @@ -335,7 +335,7 @@ let generate_managed_header base_ctx tcpp_class = 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.cl_dynamic_functions) > 0 then + if List.length (tcpp_class.tcl_dynamic_functions) > 0 then output_h ("\t\tstatic void __alloc_dynamic_functions(::hx::Ctx *_hx_alloc," ^ class_name ^ " *_hx_obj);\n"); if scriptable then @@ -372,8 +372,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - let implements_haxe = List.length tcpp_class.cl_haxe_parents > 0 in - let implements_native = List.length tcpp_class.cl_native_parents > 0 in + let implements_haxe = List.length tcpp_class.tcl_haxe_parents > 0 in + let implements_native = List.length tcpp_class.tcl_native_parents > 0 in if implements_native then ( let implemented_instance_fields = @@ -382,7 +382,7 @@ let generate_managed_header base_ctx tcpp_class = let neededInterfaceFunctions = match implements_native with | true -> - CppGen.needed_interface_functions implemented_instance_fields tcpp_class.cl_native_parents + CppGen.needed_interface_functions implemented_instance_fields tcpp_class.tcl_native_parents | false -> [] in @@ -460,7 +460,7 @@ let generate_managed_header base_ctx tcpp_class = List.iter check_field interface.cl_ordered_fields in check_interface src) - tcpp_class.cl_haxe_parents); + tcpp_class.tcl_haxe_parents); if has_init_field class_def then output_h "\t\tstatic void __init__();\n\n"; output_h @@ -469,25 +469,25 @@ let generate_managed_header base_ctx tcpp_class = if has_boot_field class_def then output_h "\t\tstatic void __boot();\n"; - tcpp_class.cl_static_functions + tcpp_class.tcl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); - tcpp_class.cl_static_dynamic_functions + tcpp_class.tcl_static_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); - tcpp_class.cl_static_variables + tcpp_class.tcl_static_variables |> List.iter (fun field -> gen_member_variable ctx class_def true field); - tcpp_class.cl_functions + tcpp_class.tcl_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); - tcpp_class.cl_dynamic_functions + tcpp_class.tcl_dynamic_functions |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); - tcpp_class.cl_variables + tcpp_class.tcl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - tcpp_class.cl_abstract_functions + tcpp_class.tcl_abstract_functions |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); output_h (get_class_code class_def Meta.HeaderClassCode); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0f90910ec44..9b4bc551eb9 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -190,9 +190,9 @@ let gen_field_init ctx class_def field = | _ -> () let generate_native_class base_ctx tcpp_class = - let class_def = tcpp_class.cl_class in + let class_def = tcpp_class.tcl_class in let class_path = class_def.cl_path in - let debug = tcpp_class.cl_debug_level 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 @@ -225,7 +225,7 @@ let generate_native_class base_ctx tcpp_class = output_cpp (get_class_code class_def Meta.CppNamespaceCode); - let class_name = tcpp_class.cl_name in + let class_name = tcpp_class.tcl_name in (match TClass.get_cl_init class_def with | Some expression -> @@ -236,16 +236,16 @@ let generate_native_class base_ctx tcpp_class = output_cpp "\n\n" | _ -> ()); - List.iter (gen_function ctx class_def class_name false) tcpp_class.cl_functions; - List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.cl_dynamic_functions; - List.iter (gen_abstract_function ctx class_def class_name) tcpp_class.cl_abstract_functions; + 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_abstract_function ctx class_def class_name) tcpp_class.tcl_abstract_functions; - List.iter (gen_function ctx class_def class_name true) tcpp_class.cl_static_functions; - List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.cl_static_dynamic_functions; - List.iter (gen_static_variable ctx class_def class_name) tcpp_class.cl_static_variables; + 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; (* Generate a dynamic function for static variables with a default function *) - tcpp_class.cl_static_variables + tcpp_class.tcl_static_variables |> List.filter_map (fun field -> match field.cf_expr with | Some { eexpr = TFunction function_def } -> Some (field, function_def) | _ -> None) @@ -253,7 +253,7 @@ let generate_native_class base_ctx tcpp_class = output_cpp "\n"; - (match tcpp_class.cl_dynamic_functions with + (match tcpp_class.tcl_dynamic_functions with | [] -> () | functions -> ( Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; @@ -294,9 +294,9 @@ let generate_native_class base_ctx tcpp_class = let generate_managed_class base_ctx tcpp_class = let common_ctx = base_ctx.ctx_common in - let class_def = tcpp_class.cl_class in + let class_def = tcpp_class.tcl_class in let class_path = class_def.cl_path in - let debug = tcpp_class.cl_debug_level 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 @@ -336,7 +336,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp (get_class_code class_def Meta.CppNamespaceCode); - let class_name = tcpp_class.cl_name in + let class_name = tcpp_class.tcl_name in let cargs = constructor_arg_var_list class_def in let constructor_var_list = List.map snd cargs in let constructor_type_args = @@ -372,7 +372,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn _hx_result;\n}\n\n"); output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); - let implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.cl_id :: tcpp_class.cl_parent_ids) in + let implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.tcl_id :: tcpp_class.tcl_parent_ids) in let txt cId = Printf.sprintf "0x%08lx" cId in let rec dump_classes indent classes = match classes with @@ -394,7 +394,7 @@ let generate_managed_class base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - let implements_haxe = List.length tcpp_class.cl_haxe_parents > 0 in + let implements_haxe = List.length tcpp_class.tcl_haxe_parents > 0 in if implements_haxe then ( let alreadyGlued = Hashtbl.create 0 in @@ -466,7 +466,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "};\n\n" in List.iter iter - tcpp_class.cl_haxe_parents; + tcpp_class.tcl_haxe_parents; output_cpp (String.concat "\n" !cpp_glue); @@ -477,7 +477,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface ^ ";\n") in List.iter iter - tcpp_class.cl_haxe_parents; + tcpp_class.tcl_haxe_parents; output_cpp "\t}\n"; @@ -505,16 +505,16 @@ let generate_managed_class base_ctx tcpp_class = List.filter should_implement_field statics_except_meta in - List.iter (gen_function ctx class_def class_name false) tcpp_class.cl_functions; - List.iter (gen_dynamic_function ctx class_def class_name false false) tcpp_class.cl_dynamic_functions; - List.iter (gen_abstract_function ctx class_def class_name) tcpp_class.cl_abstract_functions; + 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_abstract_function ctx class_def class_name) tcpp_class.tcl_abstract_functions; - List.iter (gen_function ctx class_def class_name true) tcpp_class.cl_static_functions; - List.iter (gen_dynamic_function ctx class_def class_name true false) tcpp_class.cl_static_dynamic_functions; - List.iter (gen_static_variable ctx class_def class_name) tcpp_class.cl_static_variables; + 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; (* Generate a dynamic function for static variables with a default function *) - tcpp_class.cl_static_variables + tcpp_class.tcl_static_variables |> List.filter_map (fun field -> match field.cf_expr with | Some { eexpr = TFunction function_def } -> Some (field, function_def) | _ -> None) @@ -522,7 +522,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\n"; - (match tcpp_class.cl_dynamic_functions with + (match tcpp_class.tcl_dynamic_functions with | [] -> () | functions -> ( Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; @@ -565,7 +565,7 @@ let generate_managed_class base_ctx tcpp_class = (fun (field, _) -> let name = keyword_remap field.cf_name in output_cpp ("\t" ^ name ^ " = new __default_" ^ name ^ "(this);\n")) - tcpp_class.cl_dynamic_functions; + tcpp_class.tcl_dynamic_functions; output_cpp "}\n\n"; let dump_field_iterator macro field = @@ -1207,7 +1207,7 @@ let generate_managed_class base_ctx tcpp_class = ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," ^ join_class_path_remap intf_def.cl_path "::" ^ ");\n")) - tcpp_class.cl_native_parents; + tcpp_class.tcl_native_parents; output_cpp "}\n\n"; if has_boot_field class_def then ( diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 258659f2c5d..68ee3c1e7e5 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -280,12 +280,15 @@ let remap_to_class ctx self_id parent_ids class_def = if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Var _, _ -> - Some field + if is_physical_var_field field then + Some field + else + None (* Below should cause abstracts which have functions with no implementation to be generated as a field *) | Method (MethNormal | MethInline), None when not (has_class_field_flag field CfAbstract) -> - Some field + Some field | _ -> - None + None else None in @@ -319,6 +322,7 @@ let remap_to_class ctx self_id parent_ids class_def = 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 functions = @@ -340,23 +344,28 @@ let remap_to_class ctx self_id parent_ids class_def = let haxe_implementations, native_implementations = CppGen.implementations class_def in + + let meta_field = List.find_opt (fun field -> field.cf_name = "__meta__") class_def.cl_ordered_statics in + let rtti_field = List.find_opt (fun field -> field.cf_name = "__rtti") class_def.cl_ordered_statics in { - cl_class = class_def; - cl_id = self_id; - cl_name = class_name class_def; - cl_flags = flags; - cl_parent_ids = parent_ids; - cl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; - cl_static_variables = static_variables; - cl_static_functions = static_functions; - cl_static_dynamic_functions = static_dynamic_functions; - cl_variables = variables; - cl_functions = functions; - cl_dynamic_functions = dynamic_functions; - cl_abstract_functions = abstract_functions; - cl_haxe_parents = haxe_implementations; - cl_native_parents = native_implementations; + tcl_class = class_def; + tcl_id = self_id; + tcl_name = class_name class_def; + tcl_flags = flags; + tcl_parent_ids = parent_ids; + tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; + tcl_static_variables = static_variables; + tcl_static_functions = static_functions; + tcl_static_dynamic_functions = static_dynamic_functions; + tcl_variables = variables; + tcl_functions = functions; + tcl_dynamic_functions = dynamic_functions; + tcl_abstract_functions = abstract_functions; + tcl_haxe_parents = haxe_implementations; + tcl_native_parents = native_implementations; + tcl_meta_field = meta_field; + tcl_rtti_field = rtti_field; } (* let get_all_paths cls = From e5897d42333348590fabd0d255bd5374f0247e8f Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 28 Oct 2024 23:22:44 +0000 Subject: [PATCH 30/97] create fields and default functions at class transform --- src/generators/cpp/gen/cppGenClassHeader.ml | 2 -- .../cpp/gen/cppGenClassImplementation.ml | 19 +------------- src/generators/gencpp.ml | 25 ++++++++++++------- 3 files changed, 17 insertions(+), 29 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index b26de1a4389..10d1482fa81 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -57,8 +57,6 @@ let gen_dynamic_function ctx class_def is_static field function_def = let is_not_static = not is_static in let prefix = if is_static then "\t\tstatic " else "\t\t" in - Printf.sprintf "%s::Dynamic %s;\n" prefix remap_name |> output; - if is_not_static && is_gc_element ctx TCppDynamic then Printf.sprintf "\t\tinline ::Dynamic _hx_set_%s(::hx::StackContext* _hx_ctx, ::Dynamic _hx_v) { HX_OBJ_WB(this, _hx_v.mPtr) return %s = _hx_v; }\n" remap_name remap_name |> output; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 9b4bc551eb9..7236f63113b 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -147,10 +147,7 @@ let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (f gen_cpp_function_body ctx class_def is_static func_name function_def "" "" no_debug; output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); - output "HX_END_DEFAULT_FUNC\n\n"; - - if is_static && not is_for_static_var then - output ("::Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") + output "HX_END_DEFAULT_FUNC\n\n" let gen_static_variable ctx class_def class_name field = let output = ctx.ctx_output in @@ -244,13 +241,6 @@ let generate_native_class base_ctx tcpp_class = 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; - (* Generate a dynamic function for static variables with a default function *) - tcpp_class.tcl_static_variables - |> List.filter_map (fun field -> match field.cf_expr with - | Some { eexpr = TFunction function_def } -> Some (field, function_def) - | _ -> None) - |> List.iter (gen_dynamic_function ctx class_def class_name true true); - output_cpp "\n"; (match tcpp_class.tcl_dynamic_functions with @@ -513,13 +503,6 @@ let generate_managed_class base_ctx tcpp_class = 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; - (* Generate a dynamic function for static variables with a default function *) - tcpp_class.tcl_static_variables - |> List.filter_map (fun field -> match field.cf_expr with - | Some { eexpr = TFunction function_def } -> Some (field, function_def) - | _ -> None) - |> List.iter (gen_dynamic_function ctx class_def class_name true true); - output_cpp "\n"; (match tcpp_class.tcl_dynamic_functions with diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 68ee3c1e7e5..13e779820df 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -247,20 +247,23 @@ let remap_to_class ctx self_id parent_ids class_def = if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) + Some (field, func) | _ -> - None + None else None in - let filter_dynamic_functions field = + 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 (field, func) + Some (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 (field, func) | _ -> - None + None else None in @@ -269,9 +272,9 @@ let remap_to_class ctx self_id parent_ids class_def = if should_implement_field field then match (field.cf_kind, field.cf_type) with | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> - Some (field, tl, tr) + Some (field, tl, tr) | _ -> - None + None else None in @@ -284,7 +287,11 @@ let remap_to_class ctx self_id parent_ids class_def = Some field else None + (* Dynamic methods are implemented as a physical field holding a closure *) + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some { 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 field | _ -> @@ -318,7 +325,7 @@ let remap_to_class ctx self_id parent_ids class_def = let static_dynamic_functions = class_def.cl_ordered_statics - |> List.filter_map filter_dynamic_functions in + |> List.filter_map (filter_dynamic_functions true) in let static_variables = class_def.cl_ordered_statics @@ -331,7 +338,7 @@ let remap_to_class ctx self_id parent_ids class_def = let dynamic_functions = class_def.cl_ordered_fields - |> List.filter_map filter_dynamic_functions in + |> List.filter_map (filter_dynamic_functions false) in let variables = class_def.cl_ordered_fields From 736bb0887a19966ec6f9a85d7468d4218a966502 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 28 Oct 2024 23:44:33 +0000 Subject: [PATCH 31/97] use container flag --- src/generators/cpp/cppAst.ml | 4 +- src/generators/cpp/gen/cppGen.ml | 4 +- src/generators/cpp/gen/cppGenClassHeader.ml | 2 +- .../cpp/gen/cppGenClassImplementation.ml | 25 ++++------- src/generators/gencpp.ml | 44 +++++++++---------- 5 files changed, 36 insertions(+), 43 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 880182e10e8..94c8262bdd3 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -184,8 +184,8 @@ and tcpp_class = { tcl_dynamic_functions : (tclass_field * tfunc) list; tcl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; - tcl_meta_field : tclass_field option; - tcl_rtti_field : tclass_field option; + tcl_meta : tclass_field option; + tcl_rtti : tclass_field option; } and tcpp_interface = { diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index c405b32211b..5447254f7be 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -103,9 +103,9 @@ let rec has_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 (tcpp_to_string_suffix "_obj" (cpp_instance_type klass params)) | Some (klass, _) -> find_next_super_iteration klass - | _ -> "" + | _ -> None let cpp_member_name_of member = match get_meta_string member.cf_meta Meta.Native with diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 10d1482fa81..be75cc6f454 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -366,7 +366,7 @@ let generate_managed_header base_ctx tcpp_class = ^ " *>(this)->__compare(Dynamic((::hx::Object *)inRHS)); }\n"); output_h "\t\tstatic void __register();\n"; - if has_new_gc_references class_def then ( + if has_tcpp_class_flag tcpp_class Container then ( output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 7236f63113b..99379a6fe5f 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -573,11 +573,7 @@ let generate_managed_class base_ctx tcpp_class = | _ -> ()) in - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields - in - - if has_new_gc_references class_def then ( + if has_tcpp_class_flag tcpp_class Container 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 *) @@ -585,10 +581,10 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("\tHX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n"); List.iter (dump_field_iterator "HX_MARK_MEMBER_NAME") - implemented_instance_fields; + tcpp_class.tcl_variables; (match super_needs_iteration with - | "" -> () - | super -> output_cpp ("\t" ^ super ^ "::__Mark(HX_MARK_ARG);\n")); + | None -> () + | Some super -> output_cpp ("\t" ^ super ^ "::__Mark(HX_MARK_ARG);\n")); output_cpp "\tHX_MARK_END_CLASS();\n"; output_cpp "}\n\n"; @@ -596,10 +592,10 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("void " ^ class_name ^ "::__Visit(HX_VISIT_PARAMS)\n{\n"); List.iter (dump_field_iterator "HX_VISIT_MEMBER_NAME") - implemented_instance_fields; + tcpp_class.tcl_variables; (match super_needs_iteration with - | "" -> () - | super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n")); + | None -> () + | Some super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n")); output_cpp "}\n\n"); let dump_quick_field_test fields = @@ -845,14 +841,11 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; - let stored_fields = - List.filter is_data_member implemented_instance_fields - in - if List.length stored_fields > 0 then ( + if List.length tcpp_class.tcl_variables > 0 then ( output_cpp ("static ::hx::StorageInfo " ^ class_name ^ "_sMemberStorageInfo[] = {\n"); - List.iter dump_member_storage stored_fields; + List.iter dump_member_storage tcpp_class.tcl_variables; output_cpp "\t{ ::hx::fsUnknown, 0, null()}\n};\n") else output_cpp diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 13e779820df..304c810e002 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -299,26 +299,7 @@ let remap_to_class ctx self_id parent_ids class_def = else None in - - let flags = - if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then - set_flag 0 (int_of_tcpp_class_flag Scriptable) - else - 0 - in - let flags = - if CppGen.can_quick_alloc class_def then - set_flag flags (int_of_tcpp_class_flag QuickAlloc) - else - flags - in - let flags = - if CppGen.has_gc_references class_def then - set_flag flags (int_of_tcpp_class_flag Container) - else - flags - in - + let static_functions = class_def.cl_ordered_statics |> List.filter_map filter_functions in @@ -352,6 +333,25 @@ let remap_to_class ctx self_id parent_ids class_def = CppGen.implementations class_def in + let flags = + if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then + set_flag 0 (int_of_tcpp_class_flag Scriptable) + else + 0 + in + let flags = + if CppGen.can_quick_alloc class_def then + set_flag flags (int_of_tcpp_class_flag QuickAlloc) + else + flags + in + let flags = + if List.exists (fun f -> cant_be_null f.cf_type) variables then + set_flag flags (int_of_tcpp_class_flag Container) + else + flags + in + let meta_field = List.find_opt (fun field -> field.cf_name = "__meta__") class_def.cl_ordered_statics in let rtti_field = List.find_opt (fun field -> field.cf_name = "__rtti") class_def.cl_ordered_statics in @@ -371,8 +371,8 @@ let remap_to_class ctx self_id parent_ids class_def = tcl_abstract_functions = abstract_functions; tcl_haxe_parents = haxe_implementations; tcl_native_parents = native_implementations; - tcl_meta_field = meta_field; - tcl_rtti_field = rtti_field; + tcl_meta = meta_field; + tcl_rtti = rtti_field; } (* let get_all_paths cls = From 0edf381789a7bf7f888e77164f81ca5ae7b61206 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 17:19:54 +0000 Subject: [PATCH 32/97] Mark and visit using variables and fix inverted container flag --- src/generators/cpp/cppAst.ml | 4 +- src/generators/cpp/gen/cppGenClassHeader.ml | 26 +---- .../cpp/gen/cppGenClassImplementation.ml | 101 +++++++----------- src/generators/gencpp.ml | 6 +- 4 files changed, 42 insertions(+), 95 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 94c8262bdd3..d6506ea3964 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -184,8 +184,8 @@ and tcpp_class = { tcl_dynamic_functions : (tclass_field * tfunc) list; tcl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; - tcl_meta : tclass_field option; - tcl_rtti : tclass_field option; + tcl_meta : texpr option; + tcl_rtti : texpr option; } and tcpp_interface = { diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index be75cc6f454..4cd29e557e6 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -29,37 +29,13 @@ let gen_member_variable ctx class_def is_static field = 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 remap_name tcpp_str get_ptr remap_name |> output; - - (* Add a "dyn" function for variable to unify variable/function access *) - if (not (Meta.has Meta.NativeGen class_def.cl_meta)) then - match follow field.cf_type with - | 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") - | _ -> - ())) + tcpp_str remap_name tcpp_str get_ptr remap_name |> output;) let gen_dynamic_function ctx class_def is_static field function_def = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in - let is_not_static = not is_static in let prefix = if is_static then "\t\tstatic " else "\t\t" in - if is_not_static && is_gc_element ctx TCppDynamic then - Printf.sprintf "\t\tinline ::Dynamic _hx_set_%s(::hx::StackContext* _hx_ctx, ::Dynamic _hx_v) { HX_OBJ_WB(this, _hx_v.mPtr) return %s = _hx_v; }\n" remap_name remap_name |> output; - Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix remap_name remap_name |> output let gen_abstract_function ctx class_def field tl tr = diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 99379a6fe5f..798eafd3e44 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -164,26 +164,19 @@ let gen_abstract_function ctx class_def class_name (field, tl, tr) = Printf.sprintf "HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" (List.length tl) class_name remap_name ret |> output let gen_field_init ctx class_def field = - let dot_name = join_class_path class_def.cl_path "." in - let output = ctx.ctx_output in + let dot_name = join_class_path class_def.cl_path "." in + let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in match field.cf_expr with (* Function field *) | Some { eexpr = TFunction function_def } -> - if is_dynamic_haxe_method field then - let func_name = "__default_" ^ remap_name in - output ("\t" ^ remap_name ^ " = new " ^ func_name ^ ";\n\n") + 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 *) | Some expr -> - let var_name = - match remap_name with - | "__meta__" -> "__mClass->__meta__" - | "__rtti" -> "__mClass->__rtti__" - | _ -> remap_name - in - - gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr + gen_cpp_init ctx dot_name "boot" (remap_name ^ " = ") expr | _ -> () let generate_native_class base_ctx tcpp_class = @@ -551,37 +544,17 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_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") - | _ -> ()) - in - if has_tcpp_class_flag tcpp_class Container then ( let super_needs_iteration = find_next_super_iteration class_def in let smart_class_name = snd class_path in + let dump_field_iterator macro field = + Printf.sprintf "\t%s(%s, \"%s\");\n" macro (keyword_remap field.cf_name) field.cf_name |> output_cpp + 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") - tcpp_class.tcl_variables; + 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")); @@ -590,9 +563,7 @@ let generate_managed_class base_ctx tcpp_class = (* 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; + 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")); @@ -827,40 +798,28 @@ let generate_managed_class base_ctx tcpp_class = | 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") + Printf.sprintf + "\t{ %s, (int)offsetof(%s, %s), %s }" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp in let dump_static_storage field = - output_cpp - ("\t{" ^ storage field ^ ",(void *) &" ^ class_name ^ "::" - ^ keyword_remap field.cf_name - ^ "," ^ strq field.cf_name ^ "},\n") + Printf.sprintf "\t{ %s, (void*) &%s::%s, %s }" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp in output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; if List.length tcpp_class.tcl_variables > 0 then ( - output_cpp - ("static ::hx::StorageInfo " ^ class_name - ^ "_sMemberStorageInfo[] = {\n"); + 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 - output_cpp - ("static ::hx::StorageInfo *" ^ class_name - ^ "_sMemberStorageInfo = 0;\n"); + Printf.sprintf "static ::hx::StorageInfo* %s_sMemberStorageInfo = 0;\n" class_name |> output_cpp; - 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; + 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 - output_cpp - ("static ::hx::StaticInfo *" ^ class_name ^ "_sStaticStorageInfo = 0;\n"); + Printf.sprintf "static ::hx::StaticInfo* %s_sStaticStorageInfo = 0;\n" class_name |> output_cpp; output_cpp "#endif\n\n"; @@ -1189,9 +1148,21 @@ let generate_managed_class base_ctx tcpp_class = if has_boot_field class_def then ( output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); - List.iter - (gen_field_init ctx class_def) - (List.filter should_implement_field class_def.cl_ordered_statics); + let dot_name = join_class_path class_def.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_field_init ctx class_def) tcpp_class.tcl_static_variables; + + tcpp_class.tcl_static_dynamic_functions + |> List.map fst + |> List.iter (gen_field_init ctx class_def); output_cpp "}\n\n"); diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 304c810e002..69077777b6c 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -346,14 +346,14 @@ let remap_to_class ctx self_id parent_ids class_def = flags in let flags = - if List.exists (fun f -> cant_be_null f.cf_type) variables then + if List.exists (fun f -> not (cant_be_null f.cf_type)) variables then set_flag flags (int_of_tcpp_class_flag Container) else flags in - let meta_field = List.find_opt (fun field -> field.cf_name = "__meta__") class_def.cl_ordered_statics in - let rtti_field = List.find_opt (fun field -> field.cf_name = "__rtti") class_def.cl_ordered_statics 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 { tcl_class = class_def; From 4aaac3ceba664e5bc683674e5eeec1bd07a927e5 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 17:58:00 +0000 Subject: [PATCH 33/97] static mark and visit use static variables list --- .../cpp/gen/cppGenClassImplementation.ml | 44 ++++++++----------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 798eafd3e44..f4cc74c518a 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -841,35 +841,27 @@ let generate_managed_class base_ctx tcpp_class = memberFields in - let hasMarkFunc = List.exists is_data_member implemented_fields in + if List.length tcpp_class.tcl_static_variables > 0 then ( + let dump_field_iterator macro field = + Printf.sprintf "\t%s(%s::%s, \"%s\");" macro class_name (keyword_remap field.cf_name) 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 = @@ -1112,7 +1104,7 @@ let generate_managed_class base_ctx tcpp_class = ^ if has_set_static_field class_def then class_name ^ "::__SetStatic;\n" else "::hx::Class_obj::SetNoStaticField;\n"); - if hasMarkFunc then + if List.length tcpp_class.tcl_static_variables > 0 then output_cpp ("\t__mClass->mMarkFunc = " ^ class_name ^ "_sMarkStatics;\n"); output_cpp ("\t__mClass->mStatics = ::hx::Class_obj::dupFunctions(" ^ sStaticFields @@ -1121,7 +1113,7 @@ let generate_managed_class base_ctx tcpp_class = ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields ^ ");\n"); output_cpp ("\t__mClass->mCanCast = ::hx::TCanCast< " ^ class_name ^ " >;\n"); - if hasMarkFunc then + if List.length tcpp_class.tcl_static_variables > 0 then output_cpp ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = " ^ class_name ^ "_sVisitStatics;\n#endif\n"); From 9871978cfc39ea9c5114422cf1d6f8a0689c56ed Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 20:02:29 +0000 Subject: [PATCH 34/97] print reflective fields --- .../cpp/gen/cppGenClassImplementation.ml | 85 ++++++++++--------- 1 file changed, 45 insertions(+), 40 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index f4cc74c518a..03ac13d4ee5 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -163,6 +163,35 @@ let gen_abstract_function ctx class_def class_name (field, tl, tr) = let ret = if is_void then "(void)" else "return " in Printf.sprintf "HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" (List.length tl) class_name remap_name ret |> output +let print_reflective_fields ctx_common class_def variables functions abstract_functions = + let strq = strq ctx_common in + + let filter_vars field = + if reflective class_def field then + Some (Printf.sprintf "\t%s" (strq field.cf_name)) + else + None in + let filter_funcs (field, _) = + if reflective class_def field then + Some (Printf.sprintf "\t%s" (strq field.cf_name)) + else + None in + let filter_abst (field, _, _) = + if reflective class_def field then + Some (Printf.sprintf "\t%s" (strq field.cf_name)) + else + None in + + let reflective_variables = variables |> List.filter_map filter_vars in + let reflective_functions = functions |> List.filter_map filter_funcs in + let reflective_abstracts = abstract_functions |> List.filter_map filter_abst in + + match reflective_variables @ reflective_functions @ reflective_abstracts with + | [] -> + None + | concat -> + Some (concat @ [ "\t::String(null())" ] |> String.concat ",\n") + let gen_field_init ctx class_def field = let dot_name = join_class_path class_def.cl_path "." in let output = ctx.ctx_output in @@ -482,11 +511,7 @@ let generate_managed_class base_ctx tcpp_class = 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 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; @@ -799,10 +824,10 @@ let generate_managed_class base_ctx tcpp_class = in let dump_member_storage field = Printf.sprintf - "\t{ %s, (int)offsetof(%s, %s), %s }" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp + "\t{ %s, (int)offsetof(%s, %s), %s },\n" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp in let dump_static_storage field = - Printf.sprintf "\t{ %s, (void*) &%s::%s, %s }" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp + Printf.sprintf "\t{ %s, (void*) &%s::%s, %s },\n" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp in output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; @@ -823,23 +848,11 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "#endif\n\n"; - (* cl_interface *) - let implemented_instance_fields = - List.filter should_implement_field class_def.cl_ordered_fields - in - let reflective_members = - List.filter (reflective class_def) implemented_instance_fields - 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 - in + (match print_reflective_fields ctx.ctx_common class_def tcpp_class.tcl_variables tcpp_class.tcl_functions tcpp_class.tcl_abstract_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 field = @@ -1072,17 +1085,11 @@ let generate_managed_class base_ctx tcpp_class = ("::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 + (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 ( @@ -1106,12 +1113,10 @@ let generate_managed_class base_ctx tcpp_class = 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"); - output_cpp - ("\t__mClass->mStatics = ::hx::Class_obj::dupFunctions(" ^ sStaticFields - ^ ");\n"); - output_cpp - ("\t__mClass->mMembers = ::hx::Class_obj::dupFunctions(" ^ sMemberFields - ^ ");\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 From 701f91171c37139b871fc0ec9fc53d269a4882f2 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 20:25:00 +0000 Subject: [PATCH 35/97] don't duplicate boot generation code --- .../cpp/gen/cppGenClassImplementation.ml | 91 +++++++++---------- 1 file changed, 44 insertions(+), 47 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 03ac13d4ee5..943de1e682b 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -163,6 +163,46 @@ let gen_abstract_function ctx class_def class_name (field, tl, tr) = let ret = if is_void then "(void)" else "return " in Printf.sprintf "HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" (List.length tl) class_name remap_name ret |> output +let gen_field_init ctx class_def field = + let dot_name = join_class_path class_def.cl_path "." in + let output = ctx.ctx_output in + let remap_name = keyword_remap field.cf_name in + + match field.cf_expr with + (* Function field *) + | Some { eexpr = TFunction function_def } -> + if is_dynamic_haxe_method field then + let func_name = "__default_" ^ remap_name in + output ("\t" ^ remap_name ^ " = new " ^ func_name ^ ";\n\n") + (* Data field *) + | Some expr -> + gen_cpp_init ctx dot_name "boot" (remap_name ^ " = ") expr + | _ -> () + +let gen_boot_field ctx output_cpp tcpp_class = + let class_name = tcpp_class.tcl_name in + + if has_boot_field tcpp_class.tcl_class then ( + output_cpp ("void " ^ class_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_field_init ctx tcpp_class.tcl_class) tcpp_class.tcl_static_variables; + + tcpp_class.tcl_static_dynamic_functions + |> List.map fst + |> List.iter (gen_field_init ctx tcpp_class.tcl_class); + + output_cpp "}\n\n") + let print_reflective_fields ctx_common class_def variables functions abstract_functions = let strq = strq ctx_common in @@ -192,22 +232,6 @@ let print_reflective_fields ctx_common class_def variables functions abstract_fu | concat -> Some (concat @ [ "\t::String(null())" ] |> String.concat ",\n") -let gen_field_init ctx class_def field = - let dot_name = join_class_path class_def.cl_path "." in - let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in - - match field.cf_expr with - (* Function field *) - | Some { eexpr = TFunction function_def } -> - if is_dynamic_haxe_method field then - let func_name = "__default_" ^ remap_name in - output ("\t" ^ remap_name ^ " = new " ^ func_name ^ ";\n\n") - (* Data field *) - | Some expr -> - gen_cpp_init ctx dot_name "boot" (remap_name ^ " = ") expr - | _ -> () - let generate_native_class base_ctx tcpp_class = let class_def = tcpp_class.tcl_class in let class_path = class_def.cl_path in @@ -290,15 +314,7 @@ let generate_native_class base_ctx tcpp_class = output_cpp "}\n")); generate_native_constructor ctx output_cpp class_def false; - - if has_boot_field class_def then ( - output_cpp ("void " ^ class_name ^ "::__boot()\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; @@ -550,7 +566,7 @@ let generate_managed_class base_ctx tcpp_class = let inline_constructor = can_inline_constructor base_ctx class_def in - if (not inline_constructor)&& not (has_class_flag class_def CAbstract) then + if (not inline_constructor) && not (has_class_flag class_def CAbstract) then generate_constructor ctx output_cpp tcpp_class false; let reflect_member_fields = @@ -1142,27 +1158,8 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_native_parents; output_cpp "}\n\n"; - if has_boot_field class_def then ( - output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); - - let dot_name = join_class_path class_def.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_field_init ctx class_def) tcpp_class.tcl_static_variables; - - tcpp_class.tcl_static_dynamic_functions - |> List.map fst - |> List.iter (gen_field_init ctx class_def); - - output_cpp "}\n\n"); - + gen_boot_field ctx output_cpp tcpp_class; + end_namespace output_cpp class_path; cpp_file#close \ No newline at end of file From d42df0f4691ec1775b70ab0b758a7cce3ef703bc Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 20:37:48 +0000 Subject: [PATCH 36/97] don't duplicate init function generation --- src/generators/cpp/cppAst.ml | 1 + .../cpp/gen/cppGenClassImplementation.ml | 33 ++++++++----------- src/generators/gencpp.ml | 1 + 3 files changed, 15 insertions(+), 20 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index d6506ea3964..333708a7565 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -186,6 +186,7 @@ and tcpp_class = { tcl_meta : texpr option; tcl_rtti : texpr option; + tcl_init : texpr option; } and tcpp_interface = { diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 943de1e682b..3461d746a84 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -180,10 +180,8 @@ let gen_field_init ctx class_def field = | _ -> () let gen_boot_field ctx output_cpp tcpp_class = - let class_name = tcpp_class.tcl_name in - if has_boot_field tcpp_class.tcl_class then ( - output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); + output_cpp ("void " ^ tcpp_class.tcl_name ^ "::__boot()\n{\n"); let dot_name = join_class_path tcpp_class.tcl_class.cl_path "." in @@ -203,6 +201,15 @@ let gen_boot_field ctx output_cpp tcpp_class = 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 print_reflective_fields ctx_common class_def variables functions abstract_functions = let strq = strq ctx_common in @@ -270,14 +277,7 @@ let generate_native_class base_ctx tcpp_class = let class_name = tcpp_class.tcl_name in - (match TClass.get_cl_init class_def with - | Some expression -> - let ctx = file_context base_ctx 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" - | _ -> ()); + 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; @@ -518,14 +518,7 @@ let generate_managed_class base_ctx tcpp_class = 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 base_ctx 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" - | _ -> ()); + gen_init_function ctx output_cpp tcpp_class; let statics_except_meta = statics_except_meta class_def in @@ -1159,7 +1152,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "}\n\n"; gen_boot_field ctx output_cpp tcpp_class; - + end_namespace output_cpp class_path; cpp_file#close \ No newline at end of file diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 69077777b6c..2aa12868c95 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -373,6 +373,7 @@ let remap_to_class ctx self_id parent_ids class_def = tcl_native_parents = native_implementations; tcl_meta = meta_field; tcl_rtti = rtti_field; + tcl_init = TClass.get_cl_init class_def; } (* let get_all_paths cls = From c23b8ff53a91b3069a217d7e5620337fe4e4153e Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 29 Oct 2024 21:00:58 +0000 Subject: [PATCH 37/97] don't duplicate dynamic function allocation generation --- .../cpp/gen/cppGenClassImplementation.ml | 81 ++++++++----------- 1 file changed, 32 insertions(+), 49 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 3461d746a84..db1c1afcef9 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -210,6 +210,35 @@ let gen_init_function ctx output_cpp tcpp_class = | None -> () +let gen_dynamic_function_allocator ctx output_cpp tcpp_class = + match tcpp_class.tcl_dynamic_functions with + | [] -> () + | functions -> + let mapper (field, _) = + let name = keyword_remap field.cf_name in + Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }" name name 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 + + 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 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 abstract_functions = let strq = strq ctx_common in @@ -289,29 +318,7 @@ let generate_native_class base_ctx tcpp_class = output_cpp "\n"; - (match tcpp_class.tcl_dynamic_functions with - | [] -> () - | functions -> ( - Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; - List.iter - (fun (field, _) -> - let name = keyword_remap field.cf_name in - Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }\n" name name name |> output_cpp) - 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 super - | _ -> () - in - find_super super - | _ -> ()); - 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; @@ -422,9 +429,7 @@ let generate_managed_class base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - let implements_haxe = List.length tcpp_class.tcl_haxe_parents > 0 in - - if implements_haxe then ( + if List.length tcpp_class.tcl_haxe_parents > 0 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 @@ -532,29 +537,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\n"; - (match tcpp_class.tcl_dynamic_functions with - | [] -> () - | functions -> ( - Printf.sprintf "void %s::__alloc_dynamic_functions(::hx::Ctx* _hx_ctx, %s* _hx_obj) {\n" class_name class_name |> output_cpp; - List.iter - (fun (field, _) -> - let name = keyword_remap field.cf_name in - Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }\n" name name name |> output_cpp) - 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 super - | _ -> () - in - find_super super - | _ -> ()); - output_cpp "}\n")); + gen_dynamic_function_allocator ctx output_cpp tcpp_class; let inline_constructor = can_inline_constructor base_ctx class_def From 05fafa70244dbc440883e4e397a485f892878bac Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Wed, 30 Oct 2024 23:10:38 +0000 Subject: [PATCH 38/97] generate properties and __Field function --- src/generators/cpp/cppAst.ml | 1 + .../cpp/gen/cppGenClassImplementation.ml | 80 ++++++++++--------- src/generators/gencpp.ml | 12 +++ 3 files changed, 57 insertions(+), 36 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 333708a7565..dd3ab1e787f 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -180,6 +180,7 @@ and tcpp_class = { tcl_static_dynamic_functions : (tclass_field * tfunc) list; tcl_variables : tclass_field list; + tcl_properties : tclass_field list; tcl_functions : (tclass_field * tfunc) list; tcl_dynamic_functions : (tclass_field * tfunc) list; tcl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index db1c1afcef9..b391f4b0ebb 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -616,51 +616,59 @@ let generate_managed_class base_ctx tcpp_class = 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 wrapper = 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 in + + Printf.sprintf "%s( %s )" t wrapper in let toVal f value = toCommon "::hx::Val" f value in let toDynamic f value = toCommon "" f value in + 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 + 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()") - ^ ";" )) + ("::hx::Val " ^ class_name ^ "::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n{\n"); + + let print_variable field = + let variable = keyword_remap field.cf_name |> get_wrapper field in + + match field.cf_kind with + | Var { v_read = AccCall } -> + let prop_check = checkPropCall field in + let getter = keyword_remap ("get_" ^ field.cf_name) in + + field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s ? %s() : %s );" prop_check getter variable + | _ -> + field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s );" variable in - let reflect_member_readable = - List.filter (is_readable class_def) reflect_member_fields + let print_function field = + field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name) in - dump_quick_field_test (get_field_dat reflect_member_readable); + let print_property field = + let prop_check = checkPropCall field in + let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in + field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" prop_check getter in + + let reflective_variables = tcpp_class.tcl_variables |> List.filter (reflective class_def) |> List.map print_variable in + let reflective_properties = tcpp_class.tcl_properties |> List.filter (reflective class_def) |> List.map print_property in + let reflective_functions = tcpp_class.tcl_functions |> List.map fst |> List.filter (reflective class_def) |> List.map print_function in + let reflective_abstracts = tcpp_class.tcl_abstract_functions |> List.map (fun (f, _, _) -> f) |> List.filter (reflective class_def) |> List.map print_function in + + dump_quick_field_test (reflective_variables @ reflective_functions @ reflective_abstracts @ reflective_properties); output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); if has_get_static_field class_def then ( diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 2aa12868c95..dd67750d22c 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -299,6 +299,13 @@ let remap_to_class ctx self_id parent_ids class_def = else None in + + let filter_properties field = + match field.cf_kind with + | Var _ when not (is_physical_var_field field) -> + Some field + | _ -> + None in let static_functions = class_def.cl_ordered_statics @@ -324,6 +331,10 @@ let remap_to_class ctx self_id parent_ids class_def = 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 let abstract_functions = class_def.cl_ordered_fields @@ -366,6 +377,7 @@ let remap_to_class ctx self_id parent_ids class_def = 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_abstract_functions = abstract_functions; From ef924ecadee686ca62e27ad65846173802008ae2 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 1 Nov 2024 12:49:57 +0000 Subject: [PATCH 39/97] fold right member get fields --- .../cpp/gen/cppGenClassImplementation.ml | 49 ++++++++++++------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index b391f4b0ebb..025af06a257 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -638,37 +638,52 @@ let generate_managed_class base_ctx tcpp_class = 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"); + Printf.sprintf "::hx::Val %s::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; - let print_variable field = + let print_variable field acc = + if (reflective class_def field) then let variable = keyword_remap field.cf_name |> get_wrapper field in match field.cf_kind with | Var { v_read = AccCall } -> let prop_check = checkPropCall field in - let getter = keyword_remap ("get_" ^ field.cf_name) in + let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in - field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s ? %s() : %s );" prop_check getter variable + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s ? %s : %s );" prop_check getter variable) :: acc | _ -> - field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s );" variable + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s );" variable) :: acc + else + acc + in + let print_function (field, _) acc = + if (reflective class_def field) then + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name)) :: acc + else + acc in - let print_function field = - field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name) + let print_abstract (field, _, _) acc = + if (reflective class_def field) then + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name)) :: acc + else + acc in - let print_property field = + let print_property field acc = + if (reflective class_def field) then let prop_check = checkPropCall field in - let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in - field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" prop_check getter in + let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in + (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" prop_check getter) :: acc + else + acc + in - let reflective_variables = tcpp_class.tcl_variables |> List.filter (reflective class_def) |> List.map print_variable in - let reflective_properties = tcpp_class.tcl_properties |> List.filter (reflective class_def) |> List.map print_property in - let reflective_functions = tcpp_class.tcl_functions |> List.map fst |> List.filter (reflective class_def) |> List.map print_function in - let reflective_abstracts = tcpp_class.tcl_abstract_functions |> List.map (fun (f, _, _) -> f) |> List.filter (reflective class_def) |> List.map print_function in + let all_fields = [] + |> List.fold_right print_variable tcpp_class.tcl_variables + |> List.fold_right print_property tcpp_class.tcl_properties + |> List.fold_right print_function tcpp_class.tcl_functions + |> List.fold_right print_abstract tcpp_class.tcl_abstract_functions in - dump_quick_field_test (reflective_variables @ reflective_functions @ reflective_abstracts @ reflective_properties); + dump_quick_field_test all_fields; output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); if has_get_static_field class_def then ( From 7c365b89e6a2ab8f9a8ce542ead9d4b4343344e5 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 1 Nov 2024 19:21:34 +0000 Subject: [PATCH 40/97] static get fields --- src/generators/cpp/cppAst.ml | 1 + .../cpp/gen/cppGenClassImplementation.ml | 100 ++++++++++-------- src/generators/gencpp.ml | 6 ++ 3 files changed, 60 insertions(+), 47 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index dd3ab1e787f..1eb1c7eac98 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -176,6 +176,7 @@ and tcpp_class = { tcl_native_parents : tclass list; tcl_static_variables : tclass_field list; + tcl_static_properties : tclass_field list; tcl_static_functions : (tclass_field * tfunc) list; tcl_static_dynamic_functions : (tclass_field * tfunc) list; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 025af06a257..c04154755e1 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -642,36 +642,36 @@ let generate_managed_class base_ctx tcpp_class = Printf.sprintf "::hx::Val %s::__Field(const ::String &inName,::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; let print_variable field acc = - if (reflective class_def field) then - let variable = keyword_remap field.cf_name |> get_wrapper field in + if (reflective class_def field) && not (is_abstract_impl class_def) then + let variable = keyword_remap field.cf_name |> get_wrapper field in - match field.cf_kind with - | Var { v_read = AccCall } -> - let prop_check = checkPropCall field in - let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in + match field.cf_kind with + | Var { v_read = AccCall } -> + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s ? %s : %s );" prop_check getter variable) :: acc - | _ -> + | _ -> (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s );" variable) :: acc else acc in let print_function (field, _) acc = if (reflective class_def field) then - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name)) :: acc + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name |> get_wrapper field)) :: acc else acc in let print_abstract (field, _, _) acc = if (reflective class_def field) then - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name)) :: acc + (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name |> get_wrapper field)) :: acc else acc in let print_property field acc = - if (reflective class_def field) then - let prop_check = checkPropCall field in - let getter = Printf.sprintf "get_%s()" (keyword_remap field.cf_name) in + if (reflective class_def field) && not (is_abstract_impl class_def) then + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" prop_check getter) :: acc else acc @@ -683,45 +683,51 @@ let generate_managed_class base_ctx tcpp_class = |> List.fold_right print_function tcpp_class.tcl_functions |> List.fold_right print_abstract tcpp_class.tcl_abstract_functions in - dump_quick_field_test all_fields; - output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); + 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;" )) + + output_cpp ("bool " ^ class_name ^ "::__GetStatic(const ::String &inName, Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n"); + + let print_variable field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let variable = keyword_remap field.cf_name |> get_wrapper field in + + match field.cf_kind with + | Var { v_read = AccCall } -> + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in + + (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s ? %s : %s; return true;" prop_check getter variable) :: acc + | _ -> + (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s; return true;" variable) :: acc + else + acc + in + let print_property field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in + (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { outValue = %s; return true; }" prop_check getter) :: acc + else + acc in - let reflect_static_readable = - List.filter (is_readable class_def) reflect_static_fields + let print_function (field, _) acc = + if (reflective class_def field) then + (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s_dyn(); return true;" (native_field_name_remap true field)) :: acc + else + acc in - dump_quick_field_test (get_field_dat reflect_static_readable); + + let all_fields = [] + |> List.fold_right print_variable tcpp_class.tcl_static_variables + |> List.fold_right print_property tcpp_class.tcl_static_properties + |> List.fold_right print_function tcpp_class.tcl_static_functions in + + dump_quick_field_test all_fields; output_cpp "\treturn false;\n}\n\n"); let castable f = diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index dd67750d22c..07617f2e853 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -319,6 +319,11 @@ let remap_to_class ctx self_id parent_ids class_def = 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 @@ -374,6 +379,7 @@ let remap_to_class ctx self_id parent_ids class_def = tcl_parent_ids = parent_ids; tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.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; From bfb3a747cb3c6f8f6ba40d23e8ff9880722443c1 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 1 Nov 2024 20:36:17 +0000 Subject: [PATCH 41/97] shared member and static get fold functions --- .../cpp/gen/cppGenClassImplementation.ml | 129 ++++++++---------- 1 file changed, 56 insertions(+), 73 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index c04154755e1..84f4316f61b 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -637,51 +637,60 @@ let generate_managed_class base_ctx tcpp_class = value in + let print_variable var_printer get_printer field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let variable = keyword_remap field.cf_name |> get_wrapper field in + + match field.cf_kind with + | Var { v_read = AccCall } -> + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in + + (field.cf_name, String.length field.cf_name, get_printer prop_check getter variable) :: acc + | _ -> + (field.cf_name, String.length field.cf_name, var_printer variable) :: acc + else + acc + in + let print_function printer (field, _) acc = + if (reflective class_def field) then + let ident = keyword_remap field.cf_name |> get_wrapper field in + + (field.cf_name, String.length field.cf_name, printer ident) :: acc + else + acc + in + let print_abstract printer (field, _, _) acc = + if (reflective class_def field) then + let ident = keyword_remap field.cf_name |> get_wrapper field in + + (field.cf_name, String.length field.cf_name, printer ident) :: acc + else + acc + in + let print_property printer field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let prop_check = checkPropCall field in + let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in + (field.cf_name, String.length field.cf_name, printer prop_check getter) :: acc + else + acc + in + if has_get_member_field class_def 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 print_variable field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let variable = keyword_remap field.cf_name |> get_wrapper field in - - match field.cf_kind with - | Var { v_read = AccCall } -> - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in - - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s ? %s : %s );" prop_check getter variable) :: acc - | _ -> - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s );" variable) :: acc - else - acc - in - let print_function (field, _) acc = - if (reflective class_def field) then - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name |> get_wrapper field)) :: acc - else - acc - in - let print_abstract (field, _, _) acc = - if (reflective class_def field) then - (field.cf_name, String.length field.cf_name, Printf.sprintf "return ::hx::Val( %s_dyn() );" (keyword_remap field.cf_name |> get_wrapper field)) :: acc - else - acc - in - let print_property field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in - (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { return ::hx::Val( %s ); }" prop_check getter) :: acc - else - acc - in + 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 tcpp_class.tcl_variables - |> List.fold_right print_property tcpp_class.tcl_properties - |> List.fold_right print_function tcpp_class.tcl_functions - |> List.fold_right print_abstract tcpp_class.tcl_abstract_functions in + |> 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 + |> List.fold_right (print_abstract fun_printer) tcpp_class.tcl_abstract_functions in if List.length all_fields > 0 then ( dump_quick_field_test all_fields; @@ -689,43 +698,17 @@ let generate_managed_class base_ctx tcpp_class = ); if has_get_static_field class_def then ( + Printf.sprintf "bool %s::__GetStatic(const ::String &inName, Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; - output_cpp ("bool " ^ class_name ^ "::__GetStatic(const ::String &inName, Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n"); - - let print_variable field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let variable = keyword_remap field.cf_name |> get_wrapper field in - - match field.cf_kind with - | Var { v_read = AccCall } -> - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in - - (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s ? %s : %s; return true;" prop_check getter variable) :: acc - | _ -> - (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s; return true;" variable) :: acc - else - acc - in - let print_property field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in - (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { outValue = %s; return true; }" prop_check getter) :: acc - else - acc - in - let print_function (field, _) acc = - if (reflective class_def field) then - (field.cf_name, String.length field.cf_name, Printf.sprintf "outValue = %s_dyn(); return true;" (native_field_name_remap true field)) :: acc - else - acc - 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 all_fields = [] - |> List.fold_right print_variable tcpp_class.tcl_static_variables - |> List.fold_right print_property tcpp_class.tcl_static_properties - |> List.fold_right print_function tcpp_class.tcl_static_functions in + |> 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 dump_quick_field_test all_fields; output_cpp "\treturn false;\n}\n\n"); From 4034ca50cd2086d641d613ed5a160df8cca609b2 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 2 Nov 2024 16:36:42 +0000 Subject: [PATCH 42/97] static set function uses ordered fields --- .../cpp/gen/cppGenClassImplementation.ml | 71 ++++++++++--------- 1 file changed, 39 insertions(+), 32 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 84f4316f61b..1c5365fabc5 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -625,7 +625,6 @@ let generate_managed_class base_ctx tcpp_class = Printf.sprintf "%s( %s )" t wrapper in let toVal f value = toCommon "::hx::Val" f value in - let toDynamic f value = toCommon "" f value in let get_wrapper field value = match cpp_type_of field.cf_type with @@ -763,40 +762,48 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn super::__SetField(inName,inValue,inCallProp);\n}\n\n"); 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 )) + Printf.sprintf "bool %s::__SetStatic(const ::String& inName, ::Dynamic& ioValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; + + let fold_variable field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let ident = keyword_remap field.cf_name in + let casted = castable field in + + match field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall field in + let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in + let call = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted ident casted in + + (field.cf_name, String.length field.cf_name, call) :: acc + | Var { v_write = AccNormal | AccNo } -> + (field.cf_name, String.length field.cf_name, Printf.sprintf "%s = ioValue.Cast< %s >(); return true;" ident casted) :: acc + | _ -> + acc + else + acc in - 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 + let fold_property field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + match field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall field in + let setter = keyword_remap field.cf_name |> Printf.sprintf "set_%s" |> get_wrapper field in + let casted = castable field in + + (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); }" prop_call setter casted) :: acc + | _ -> + acc + else + acc in - dump_quick_field_test (set_field_dat reflect_write_static_variables); + + 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) *) From 3344a7730e00c36fd67ae9d36bcc49598ffb238d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 10:36:14 +0000 Subject: [PATCH 43/97] member set uses organised fields --- src/generators/cpp/cppAst.ml | 4 + .../cpp/gen/cppGenClassImplementation.ml | 114 +++++++++--------- src/generators/gencpp.ml | 7 +- 3 files changed, 63 insertions(+), 62 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 1eb1c7eac98..80cefa9c415 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -163,6 +163,10 @@ and tcpp_class_flags = | QuickAlloc | Container | Scriptable + | MemberGet + | MemberSet + | StaticGet + | StaticSet and tcpp_class = { tcl_class : tclass; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 1c5365fabc5..00a01b27513 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -545,9 +545,6 @@ let generate_managed_class base_ctx tcpp_class = if (not inline_constructor) && not (has_class_flag class_def CAbstract) then generate_constructor ctx output_cpp tcpp_class 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 in @@ -615,17 +612,6 @@ let generate_managed_class base_ctx tcpp_class = else "inCallProp == ::hx::paccAlways" in - let toCommon t f value = - let wrapper = 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 in - - Printf.sprintf "%s( %s )" t wrapper - in - let toVal f value = toCommon "::hx::Val" f value in - 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 -> @@ -651,6 +637,7 @@ let generate_managed_class base_ctx tcpp_class = else acc in + let print_function printer (field, _) acc = if (reflective class_def field) then let ident = keyword_remap field.cf_name |> get_wrapper field in @@ -659,6 +646,7 @@ let generate_managed_class base_ctx tcpp_class = else acc in + let print_abstract printer (field, _, _) acc = if (reflective class_def field) then let ident = keyword_remap field.cf_name |> get_wrapper field in @@ -667,6 +655,7 @@ let generate_managed_class base_ctx tcpp_class = else acc in + let print_property printer field acc = if (reflective class_def field) && not (is_abstract_impl class_def) then let prop_check = checkPropCall field in @@ -675,6 +664,14 @@ let generate_managed_class base_ctx tcpp_class = 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_get_member_field class_def then ( (* Dynamic "Get" Field function - string version *) @@ -712,53 +709,56 @@ let generate_managed_class base_ctx tcpp_class = dump_quick_field_test all_fields; 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 - - (* 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 + Printf.sprintf "::hx::Val %s::__SetField(const ::String& inName, const ::hx::Val& inValue, ::hx::PropertyAccess inPropCall)\n{\n" class_name |> output_cpp; - let reflect_member_writable = - List.filter (is_writable class_def) reflect_member_fields + let fold_variable field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let ident = keyword_remap field.cf_name in + let casted = castable field in + let default = if is_gc_element ctx (cpp_type_of field.cf_type) then + Printf.sprintf "_hx_set_%s(HX_CTX_GET, inValue.Cast< %s >()); return inValue;" ident casted + else + Printf.sprintf "%s = inValue.Cast< %s >(); return inValue;" ident casted in + + match field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall field in + let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in + let call = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); } else { %s }" prop_call setter casted default in + + (field.cf_name, String.length field.cf_name, call) :: acc + | Var { v_write = AccNormal | AccNo | AccNever } -> + (field.cf_name, String.length field.cf_name, default) :: acc + | _ -> + acc + else + acc in - let reflect_write_member_variables = - List.filter variable_field reflect_member_writable + + let fold_property field acc = + if (reflective class_def field) && not (is_abstract_impl class_def) then + let ident = keyword_remap field.cf_name in + let casted = castable field in + + match field.cf_kind with + | Var { v_write = AccCall } -> + let prop_call = checkPropCall field in + let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in + let call = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); }" prop_call setter casted in + + (field.cf_name, String.length field.cf_name, call) :: acc + | _ -> + acc + else + acc in - dump_quick_field_test (set_field_dat reflect_write_member_variables); + + 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"); if has_set_static_field class_def then ( diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 07617f2e853..295f8da441a 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -280,13 +280,10 @@ let remap_to_class ctx self_id parent_ids class_def = in let filter_variables field = - if should_implement_field field then + if is_physical_field field then match (field.cf_kind, field.cf_expr) with | Var _, _ -> - if is_physical_var_field field then - Some field - else - None + Some field (* Dynamic methods are implemented as a physical field holding a closure *) | Method MethDynamic, Some { eexpr = TFunction func } -> Some { field with cf_expr = None; cf_kind = Var ({ v_read = AccNormal; v_write = AccNormal }) } From d3cc1db7984aa6e5248d417f7c9bd06cdf5765ee Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 13:29:54 +0000 Subject: [PATCH 44/97] turn abstract functions into normal functions --- src/generators/cpp/cppAst.ml | 1 - src/generators/cpp/gen/cppGenClassHeader.ml | 41 --------------- .../cpp/gen/cppGenClassImplementation.ml | 38 +++----------- src/generators/gencpp.ml | 51 +++++++++++++------ 4 files changed, 41 insertions(+), 90 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 80cefa9c415..567b94615ba 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -188,7 +188,6 @@ and tcpp_class = { tcl_properties : tclass_field list; tcl_functions : (tclass_field * tfunc) list; tcl_dynamic_functions : (tclass_field * tfunc) list; - tcl_abstract_functions : (tclass_field * (string * bool * t) list * t) list; tcl_meta : texpr option; tcl_rtti : texpr option; diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 4cd29e557e6..e168f52491a 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -38,41 +38,6 @@ let gen_dynamic_function ctx class_def is_static field function_def = Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix remap_name remap_name |> output -let gen_abstract_function ctx class_def field tl tr = - - (* Default values for abstract classes are stored in @:Value metadata *) - (* So we need to inspect that to see which, if any, arguments of an abstract function have default values *) - 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 - (decls - |> List.find (fun ((n, _, _), _) -> n = name) - |> snd - |> type_constant_value ctx.ctx_common.basic) - | _ -> None - with Not_found -> None - in - - arg_list - |> List.map (fun (n, o, t) -> print_arg n (get_default_value n) t prefix) - |> String.concat "," - in - let output = ctx.ctx_output in - let return_type = type_to_string tr in - let remap_name = native_field_name_remap false field in - - Printf.sprintf - "\t\tvirtual %s %s(%s) %s\n" - (if return_type = "Void" then "void" else return_type) - remap_name - (ctx_arg_list ctx tl "") - (if return_type = "void" then "{}" else "{ return 0; }") |> output; - - if reflective class_def field then Printf.sprintf "\t\t::Dynamic %s_dyn();\n" remap_name |> output - let gen_member_function ctx class_def is_static field function_def = let output = ctx.ctx_output in let is_non_virtual = Meta.has Meta.NonVirtual field.cf_meta in @@ -222,9 +187,6 @@ let generate_native_header base_ctx tcpp_class = tcpp_class.tcl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - tcpp_class.tcl_abstract_functions - |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); - output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; @@ -461,9 +423,6 @@ let generate_managed_header base_ctx tcpp_class = tcpp_class.tcl_variables |> List.iter (fun field -> gen_member_variable ctx class_def false field); - tcpp_class.tcl_abstract_functions - |> List.iter (fun (field, tl, tr) -> gen_abstract_function ctx class_def field tl tr); - 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 00a01b27513..9c7ae568762 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -155,14 +155,6 @@ let gen_static_variable ctx class_def class_name field = gen_type ctx field.cf_type; output (" " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") -let gen_abstract_function ctx class_def class_name (field, tl, tr) = - let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name 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 - Printf.sprintf "HX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" (List.length tl) class_name remap_name ret |> output - let gen_field_init ctx class_def field = let dot_name = join_class_path class_def.cl_path "." in let output = ctx.ctx_output in @@ -239,7 +231,7 @@ let gen_dynamic_function_allocator ctx output_cpp tcpp_class = 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 abstract_functions = +let print_reflective_fields ctx_common class_def variables functions = let strq = strq ctx_common in let filter_vars field = @@ -252,17 +244,11 @@ let print_reflective_fields ctx_common class_def variables functions abstract_fu Some (Printf.sprintf "\t%s" (strq field.cf_name)) else None in - let filter_abst (field, _, _) = - if reflective class_def field then - Some (Printf.sprintf "\t%s" (strq field.cf_name)) - else - None in let reflective_variables = variables |> List.filter_map filter_vars in let reflective_functions = functions |> List.filter_map filter_funcs in - let reflective_abstracts = abstract_functions |> List.filter_map filter_abst in - match reflective_variables @ reflective_functions @ reflective_abstracts with + match reflective_variables @ reflective_functions with | [] -> None | concat -> @@ -310,7 +296,6 @@ let generate_native_class base_ctx 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_abstract_function ctx class_def class_name) tcpp_class.tcl_abstract_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; @@ -529,7 +514,6 @@ let generate_managed_class base_ctx 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_abstract_function ctx class_def class_name) tcpp_class.tcl_abstract_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; @@ -647,15 +631,6 @@ let generate_managed_class base_ctx tcpp_class = acc in - let print_abstract printer (field, _, _) acc = - if (reflective class_def field) then - let ident = keyword_remap field.cf_name |> get_wrapper field in - - (field.cf_name, String.length field.cf_name, printer ident) :: acc - else - acc - in - let print_property printer field acc = if (reflective class_def field) && not (is_abstract_impl class_def) then let prop_check = checkPropCall field in @@ -685,8 +660,7 @@ let generate_managed_class base_ctx tcpp_class = 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 - |> List.fold_right (print_abstract fun_printer) tcpp_class.tcl_abstract_functions in + |> 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; @@ -710,7 +684,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn false;\n}\n\n"); if has_set_member_field class_def then ( - Printf.sprintf "::hx::Val %s::__SetField(const ::String& inName, const ::hx::Val& inValue, ::hx::PropertyAccess inPropCall)\n{\n" class_name |> output_cpp; + Printf.sprintf "::hx::Val %s::__SetField(const ::String& inName, const ::hx::Val& inValue, ::hx::PropertyAccess inCallProp)\n{\n" class_name |> output_cpp; let fold_variable field acc = if (reflective class_def field) && not (is_abstract_impl class_def) then @@ -859,7 +833,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "#endif\n\n"; - (match print_reflective_fields ctx.ctx_common class_def tcpp_class.tcl_variables tcpp_class.tcl_functions tcpp_class.tcl_abstract_functions with + (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 -> @@ -1096,7 +1070,7 @@ let generate_managed_class base_ctx tcpp_class = ("::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 + (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 -> diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 295f8da441a..4332647c686 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -244,10 +244,45 @@ let is_assign_op op = let remap_to_class ctx self_id parent_ids class_def = let filter_functions field = + let abstract_to_function () = + 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 + 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 + if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> Some (field, func) + | Method MethNormal, _ when has_class_field_flag field CfAbstract -> + Some (field, abstract_to_function ()) | _ -> None else @@ -268,17 +303,6 @@ let remap_to_class ctx self_id parent_ids class_def = None in - let filter_abstract_functions field = - if should_implement_field field then - match (field.cf_kind, field.cf_type) with - | Method MethNormal, TFun (tl, tr) when has_class_field_flag field CfAbstract -> - Some (field, tl, tr) - | _ -> - None - else - None - in - let filter_variables field = if is_physical_field field then match (field.cf_kind, field.cf_expr) with @@ -337,10 +361,6 @@ let remap_to_class ctx self_id parent_ids class_def = let properties = class_def.cl_ordered_fields |> List.filter_map filter_properties in - - let abstract_functions = - class_def.cl_ordered_fields - |> List.filter_map filter_abstract_functions in let haxe_implementations, native_implementations = CppGen.implementations class_def @@ -383,7 +403,6 @@ let remap_to_class ctx self_id parent_ids class_def = tcl_properties = properties; tcl_functions = functions; tcl_dynamic_functions = dynamic_functions; - tcl_abstract_functions = abstract_functions; tcl_haxe_parents = haxe_implementations; tcl_native_parents = native_implementations; tcl_meta = meta_field; From dc1adbf8627658673476550e247c92c561248555 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 16:18:26 +0000 Subject: [PATCH 45/97] cppia gen uses organised functions --- src/generators/cpp/cppTypeUtils.ml | 47 +++++++++++-------- .../cpp/gen/cppGenClassImplementation.ml | 24 ++-------- 2 files changed, 32 insertions(+), 39 deletions(-) diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index ea1c3bff140..9d3f42c2b8e 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -323,32 +323,39 @@ 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) - | _ -> [] - ) + 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 - List.rev (all_virtual_functions_rec clazz) + + 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 |> List.rev let class_name class_def = let (_, class_path) = class_def.cl_path in diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 9c7ae568762..0e0dcb37767 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -510,8 +510,6 @@ let generate_managed_class base_ctx tcpp_class = gen_init_function ctx output_cpp tcpp_class; - let statics_except_meta = statics_except_meta class_def in - 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; @@ -529,10 +527,6 @@ let generate_managed_class base_ctx tcpp_class = if (not inline_constructor) && not (has_class_flag class_def CAbstract) then generate_constructor ctx output_cpp tcpp_class false; - let reflect_static_fields = - List.filter (reflective class_def) statics_except_meta - in - (* Initialise non-static variables *) output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); List.iter @@ -950,7 +944,6 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "}\n"; in - let new_sctipt_functions = List.rev (current_virtual_functions_rev class_def []) in let sctipt_name = class_name ^ "__scriptable" in output_cpp ("class " ^ sctipt_name ^ " : public " ^ class_name ^ " {\n"); @@ -996,22 +989,15 @@ let generate_managed_class base_ctx tcpp_class = let sigs = Hashtbl.create 0 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 - in - - if List.length all_script_functions > 0 then ( + if List.length tcpp_class.tcl_functions > 0 || List.length tcpp_class.tcl_static_functions > 0 then ( List.iter - (fun (f, _, _) -> + (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; + tcpp_class.tcl_functions; let dump_script_static f = let s = @@ -1041,8 +1027,8 @@ let generate_managed_class base_ctx tcpp_class = 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; + List.iter (fun (f, _) -> dump_func f "false") tcpp_class.tcl_functions; + List.iter (fun (f, _) -> dump_func f "true") tcpp_class.tcl_static_functions; output_cpp " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n") else From 77bc03adc886982767d09c45fe90b700dcb289ec Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 17:18:24 +0000 Subject: [PATCH 46/97] simplify ScriptNamedFunction generation --- .../cpp/gen/cppGenClassImplementation.ml | 61 +++++++------------ 1 file changed, 22 insertions(+), 39 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0e0dcb37767..0c7d79054e1 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -987,53 +987,36 @@ let generate_managed_class base_ctx tcpp_class = list_iteri dump_script_field functions; output_cpp "};\n\n"; - let sigs = Hashtbl.create 0 in - if List.length tcpp_class.tcl_functions > 0 || List.length tcpp_class.tcl_static_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) - tcpp_class.tcl_functions; - 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 + let dump_script is_static (f, _) acc = + let signature = generate_script_function is_static f ("__s_" ^ f.cf_name) (keyword_remap f.cf_name) in + let superCall = if is_static then "0" else "__s_" ^ f.cf_name ^ "" in + let named = + Printf.sprintf + "\t::hx::ScriptNamedFunction(\"%s\", __s_%s, \"%s\", %s HXCPP_CPPIA_SUPER_ARG(%s))" + f.cf_name + f.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" 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") tcpp_class.tcl_functions; - List.iter (fun (f, _) -> dump_func f "true") tcpp_class.tcl_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";); + output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n"); let class_name_text = join_class_path class_path "." in From 7200bcba28874fdfa7b9b7f0bd7acd6aa199878d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 18:51:09 +0000 Subject: [PATCH 47/97] bit of simplification of more cppia stuff --- .../cpp/gen/cppGenClassImplementation.ml | 45 ++++++------------- 1 file changed, 14 insertions(+), 31 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0c7d79054e1..2d4527596ce 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -924,8 +924,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("\tif (" ^ vtable ^ ") {\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"); + output_cpp ("\t\t__ctx->pushObject( this );\n"); List.iter (fun (name, opt, t) -> output_cpp @@ -949,42 +948,26 @@ let generate_managed_class base_ctx tcpp_class = 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 + (fun (f, _) -> f.cf_name = "toString") + tcpp_class.tcl_static_functions || + List.exists + (fun (f, tfunc) -> f.cf_name = "toString" && List.length tfunc.tf_args <> 0) + tcpp_class.tcl_functions in let super_string = if has_funky_toString then class_name ^ "::super" else class_name in - output_cpp (" typedef " ^ super_string ^ " __superString;\n"); - output_cpp - (" HX_DEFINE_SCRIPTABLE(HX_ARR_LIST" - ^ string_of_int (List.length constructor_var_list) - ^ ")\n"); - output_cpp "\tHX_DEFINE_SCRIPTABLE_DYNAMIC;\n"; - let list_iteri func in_list = - let idx = ref 0 in - List.iter - (fun elem -> - func !idx elem; - idx := !idx + 1) - in_list - in + 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"; - let not_toString (field, args, _) = field.cf_name <> "toString" in - let functions = List.filter not_toString (all_virtual_functions class_def) in - list_iteri dump_script_field functions; + class_def + |> all_virtual_functions + |> List.filter (fun (field, _, _) -> field.cf_name <> "toString") + |> ExtList.List.iteri dump_script_field; output_cpp "};\n\n"; if List.length tcpp_class.tcl_functions > 0 || List.length tcpp_class.tcl_static_functions > 0 then ( @@ -1003,7 +986,7 @@ let generate_managed_class base_ctx tcpp_class = 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 From 8e8e3426ebf8b6b84f6b85cea2fcc4e133ae212a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 3 Nov 2024 19:25:29 +0000 Subject: [PATCH 48/97] GetFields uses organised fields --- .../cpp/gen/cppGenClassImplementation.ml | 23 ++++++++----------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 2d4527596ce..1393296fc18 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -776,20 +776,15 @@ let generate_managed_class base_ctx tcpp_class = (* 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 - 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 append field acc = (strq 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 @@ -960,7 +955,7 @@ let generate_managed_class base_ctx tcpp_class = if has_funky_toString then class_name ^ "::super" else class_name in - Printf.sprintf "\ttypedef %s__superString;\n" super_string |> 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"; From 36e5870d6d87bdf70f88bd2acca6aa366dfe47bd Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 4 Nov 2024 17:54:30 +0000 Subject: [PATCH 49/97] move class retyping into retyper --- src/generators/cpp/cppAst.ml | 4 +- src/generators/cpp/cppRetyper.ml | 186 ++++++++++++++++- src/generators/cpp/cppTypeUtils.ml | 20 ++ src/generators/cpp/gen/cppGen.ml | 39 ---- src/generators/cpp/gen/cppGenClassHeader.ml | 8 +- .../cpp/gen/cppGenClassImplementation.ml | 8 +- src/generators/gencpp.ml | 187 +----------------- 7 files changed, 216 insertions(+), 236 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 567b94615ba..c731d4db189 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -176,8 +176,8 @@ and tcpp_class = { tcl_flags : int; tcl_debug_level : int; - tcl_haxe_parents : tclass list; - tcl_native_parents : tclass list; + tcl_haxe_interfaces : tclass list; + tcl_native_interfaces : tclass list; tcl_static_variables : tclass_field list; tcl_static_properties : tclass_field list; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 9436657e5fc..55d0f863dc2 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1431,4 +1431,188 @@ let expression ctx request_type function_args function_type expression_tree forI mk_cppexpr (CppCastScalar (cppExpr, too)) return_type | _ -> cppExpr in - retype request_type expression_tree \ No newline at end of file + retype request_type expression_tree + +let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = + let filter_functions field = + let abstract_to_function () = + 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 + 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 + + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | Method MethNormal, _ when has_class_field_flag field CfAbstract -> + Some (field, abstract_to_function ()) + | _ -> + 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 (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 (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 field + (* Dynamic methods are implemented as a physical field holding a closure *) + | Method MethDynamic, Some { eexpr = TFunction func } -> + Some { 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 field + | _ -> + None + else + None + in + + let filter_properties field = + match field.cf_kind with + | Var _ when not (is_physical_var_field field) -> + Some field + | _ -> + None in + + let static_functions = + class_def.cl_ordered_statics + |> List.filter_map filter_functions 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 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 (haxe, native) (interface, _) = + let acc = if is_native_class interface then + List.fold_left folder (haxe, PathMap.add interface.cl_path interface native) interface.cl_implements + else + List.fold_left folder (PathMap.add interface.cl_path interface haxe, native) interface.cl_implements in + + match interface.cl_super with + | Some super -> folder acc super + | None -> acc + in + let values (haxe, native) = + haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in + + let haxe_implementations, native_implementations = + class_def.cl_implements + |> real_interfaces + |> List.fold_left folder (PathMap.empty, PathMap.empty) + |> values in + + let flags = + if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then + set_flag 0 (int_of_tcpp_class_flag Scriptable) + else + 0 + in + let flags = + if can_quick_alloc class_def then + set_flag flags (int_of_tcpp_class_flag QuickAlloc) + else + flags + in + let flags = + if List.exists (fun f -> not (cant_be_null f.cf_type)) variables then + set_flag flags (int_of_tcpp_class_flag Container) + else + flags + 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 + + { + tcl_class = class_def; + tcl_id = self_id; + tcl_name = class_name class_def; + tcl_flags = flags; + tcl_parent_ids = parent_ids; + tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.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; + } \ No newline at end of file diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index 9d3f42c2b8e..f06a674ee5d 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -70,6 +70,26 @@ 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 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 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) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 5447254f7be..a25d6d7e220 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -176,19 +176,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 @@ -383,12 +370,6 @@ 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 @@ -496,26 +477,6 @@ 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 rec folder (haxe, native) (interface, _) = - let acc = if is_native_class interface then - List.fold_left folder (haxe, PathMap.add interface.cl_path interface native) interface.cl_implements - else - List.fold_left folder (PathMap.add interface.cl_path interface haxe, native) interface.cl_implements in - - match interface.cl_super with - | Some super -> folder acc super - | None -> acc - in - let values (haxe, native) = - haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in - - class_def.cl_implements - |> real_interfaces - |> List.fold_left folder (PathMap.empty, PathMap.empty) - |> values - let needed_interface_functions implemented_instance_fields native_implementations = let have = implemented_instance_fields diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index e168f52491a..d39b0694d1f 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -308,8 +308,8 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - let implements_haxe = List.length tcpp_class.tcl_haxe_parents > 0 in - let implements_native = List.length tcpp_class.tcl_native_parents > 0 in + let implements_haxe = List.length tcpp_class.tcl_haxe_interfaces > 0 in + let implements_native = List.length tcpp_class.tcl_native_interfaces > 0 in if implements_native then ( let implemented_instance_fields = @@ -318,7 +318,7 @@ let generate_managed_header base_ctx tcpp_class = let neededInterfaceFunctions = match implements_native with | true -> - CppGen.needed_interface_functions implemented_instance_fields tcpp_class.tcl_native_parents + CppGen.needed_interface_functions implemented_instance_fields tcpp_class.tcl_native_interfaces | false -> [] in @@ -396,7 +396,7 @@ let generate_managed_header base_ctx tcpp_class = List.iter check_field interface.cl_ordered_fields in check_interface src) - tcpp_class.tcl_haxe_parents); + tcpp_class.tcl_haxe_interfaces); if has_init_field class_def then output_h "\t\tstatic void __init__();\n\n"; output_h diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 1393296fc18..ef1d597806d 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -414,7 +414,7 @@ let generate_managed_class base_ctx tcpp_class = dump_classes "\t" implemented_classes; output_cpp "}\n\n"; - if List.length tcpp_class.tcl_haxe_parents > 0 then ( + if List.length tcpp_class.tcl_haxe_interfaces > 0 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 @@ -484,7 +484,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "};\n\n" in List.iter iter - tcpp_class.tcl_haxe_parents; + tcpp_class.tcl_haxe_interfaces; output_cpp (String.concat "\n" !cpp_glue); @@ -495,7 +495,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface ^ ";\n") in List.iter iter - tcpp_class.tcl_haxe_parents; + tcpp_class.tcl_haxe_interfaces; output_cpp "\t}\n"; @@ -1071,7 +1071,7 @@ let generate_managed_class base_ctx tcpp_class = ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," ^ join_class_path_remap intf_def.cl_path "::" ^ ");\n")) - tcpp_class.tcl_native_parents; + tcpp_class.tcl_native_interfaces; output_cpp "}\n\n"; gen_boot_field ctx output_cpp tcpp_class; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 4332647c686..64fe91a68a4 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -242,191 +242,6 @@ let is_assign_op op = | OpAssignOp _ -> true | _ -> false -let remap_to_class ctx self_id parent_ids class_def = - let filter_functions field = - let abstract_to_function () = - 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 - 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 - - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) - | Method MethNormal, _ when has_class_field_flag field CfAbstract -> - Some (field, abstract_to_function ()) - | _ -> - 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 (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 (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 field - (* Dynamic methods are implemented as a physical field holding a closure *) - | Method MethDynamic, Some { eexpr = TFunction func } -> - Some { 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 field - | _ -> - None - else - None - in - - let filter_properties field = - match field.cf_kind with - | Var _ when not (is_physical_var_field field) -> - Some field - | _ -> - None in - - let static_functions = - class_def.cl_ordered_statics - |> List.filter_map filter_functions 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 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 - - let haxe_implementations, native_implementations = - CppGen.implementations class_def - in - - let flags = - if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then - set_flag 0 (int_of_tcpp_class_flag Scriptable) - else - 0 - in - let flags = - if CppGen.can_quick_alloc class_def then - set_flag flags (int_of_tcpp_class_flag QuickAlloc) - else - flags - in - let flags = - if List.exists (fun f -> not (cant_be_null f.cf_type)) variables then - set_flag flags (int_of_tcpp_class_flag Container) - else - flags - 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 - - { - tcl_class = class_def; - tcl_id = self_id; - tcl_name = class_name class_def; - tcl_flags = flags; - tcl_parent_ids = parent_ids; - tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.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_parents = haxe_implementations; - tcl_native_parents = native_implementations; - tcl_meta = meta_field; - tcl_rtti = rtti_field; - tcl_init = TClass.get_cl_init class_def; - } - - (* let get_all_paths cls = - match CppStrings.get_all_meta_string_path cls.cl_meta Meta.Include with - | [] -> [ class_def.cl_path ] - | files -> List.map CppStrings.path_of_string files in - - let parent_includes = - match class_def.cl_super with - | Some (klass, _) -> get_all_paths klass - | _ -> [] in - - let implements_includes = - class_def.cl_implements - |> CppGen.real_interfaces - |> List.map (fun (interface, _) -> get_all_paths interface) - |> List.flatten in - () *) - (* The common_ctx contains the haxe AST in the "types" field and the resources *) @@ -550,7 +365,7 @@ let generate_source ctx = } in if native_gen then (NativeInterface iface) else (ManagedInterface iface) | false -> - let cls = remap_to_class ctx self_id parent_ids class_def in + let cls = CppRetyper.tcpp_class_from_tclass ctx self_id parent_ids class_def in if native_gen then (NativeClass cls) else (ManagedClass cls) in let acc_decls = decl :: acc.decls in From 1d1efee3bca372e03b5cc64e5d494887f11db72a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 4 Nov 2024 22:50:35 +0000 Subject: [PATCH 50/97] remap interface functions --- src/generators/cpp/cppAst.ml | 9 +- src/generators/cpp/cppRetyper.ml | 19 +++ .../cpp/gen/cppGenInterfaceHeader.ml | 88 ++++++------- .../cpp/gen/cppGenInterfaceImplementation.ml | 124 ++++++++---------- src/generators/gencpp.ml | 8 +- 5 files changed, 118 insertions(+), 130 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index c731d4db189..7e8e8c56b84 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -194,11 +194,18 @@ and tcpp_class = { tcl_init : texpr option; } +and tcpp_interface_function = { + iff_field : tclass_field; + iff_name : string; + iff_args : (string * bool * t) list; + iff_return : t; +} + and tcpp_interface = { if_class : tclass; if_name : string; if_debug_level : int; - if_virtual_functions : (tclass_field * (string * bool * t) list * t) list + if_functions : tcpp_interface_function list } and tcpp_enum_field = { diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 55d0f863dc2..f65a5e5d7ee 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1615,4 +1615,23 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = tcl_meta = meta_field; tcl_rtti = rtti_field; tcl_init = TClass.get_cl_init class_def; + } + +and tcpp_interface_from_tclass ctx class_def = + + let retype_function (field, args, ret) = + { + iff_field = field; + iff_name = keyword_remap field.cf_name; + iff_args = args; + iff_return = ret; + } in + + let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in + let functions = class_def |> all_virtual_functions |> List.map retype_function in + { + if_class = class_def; + if_name = class_name class_def; + if_debug_level = debug_level; + if_functions = functions; } \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index d989ee8ce14..65a5edac0ad 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -16,53 +16,40 @@ let attribs common_ctx = match Common.defined common_ctx Define.DllExport with | true -> "HXCPP_EXTERN_CLASS_ATTRIBUTES" | false -> "HXCPP_CLASS_ATTRIBUTES" -let gen_member_def ctx class_def field = - match (follow field.cf_type, field.cf_kind) with - | _, Method MethDynamic -> () - | TFun (args, return_type), Method _ -> - 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 - let gen_args = print_tfun_arg_list true in - - if nativeGen then ( - output ("\t\tvirtual " ^ type_to_string return_type); - output (" " ^ remap_name ^ "( "); - output (gen_args args); - output ")=0;\n"; - if reflective class_def field then - if Common.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")) +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 Common.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 - 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") - | _ -> () + 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 (cpp_class_hash interface.if_class) func.iff_name (print_arg_names func.iff_args) |> output let gen_includes h_file interface_def = let add_class_includes cls = @@ -100,11 +87,10 @@ let gen_header_includes interface_def output_h = let printer inc = output_h ("#include \"" ^ inc ^ "\"\n") in List.iter printer includes -let gen_body tcpp_interface ctx output_h = +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"; - tcpp_interface.if_virtual_functions - |> List.iter (fun (field, _, _) -> gen_member_def ctx tcpp_interface.if_class field); + List.iter iter tcpp_interface.if_functions; match get_meta_string tcpp_interface.if_class.cl_meta Meta.ObjcProtocol with | Some protocol -> @@ -154,7 +140,7 @@ let generate_native_interface base_ctx tcpp_interface = CppGen.generate_native_constructor ctx output_h tcpp_interface.if_class true; - gen_body tcpp_interface ctx output_h; + gen_body tcpp_interface ctx output_h (gen_native_function ctx tcpp_interface); output_h "};\n\n"; @@ -195,7 +181,7 @@ let generate_managed_interface base_ctx tcpp_interface = output_h ("\t\ttypedef " ^ super ^ " super;\n"); output_h "\t\tHX_DO_INTERFACE_RTTI;\n\n"; - gen_body tcpp_interface ctx output_h; + gen_body tcpp_interface ctx output_h (gen_function ctx tcpp_interface); output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index e2786e085fe..20a5f7e3bc9 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -162,13 +162,12 @@ let generate_managed_interface base_ctx tcpp_interface = in if scriptable then ( - let dump_script_field idx (field, f_args, return_t) = - let args = print_tfun_arg_list true f_args in - let return_type = type_to_string return_t in + 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 - let name = keyword_remap field.cf_name in - output_cpp ("\t" ^ return_type ^ " " ^ name ^ "( " ^ args ^ " ) {\n"); + 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"; @@ -177,18 +176,18 @@ let generate_managed_interface base_ctx tcpp_interface = 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 + func.iff_args; + let interfaceSlot = string_of_int (-cpp_get_interface_slot ctx func.iff_name) in output_cpp ("\t\t" ^ ret ^ "__ctx->run" - ^ CppCppia.script_type return_t false + ^ CppCppia.script_type func.iff_return false ^ "(__GetScriptVTable()[" ^ interfaceSlot ^ "]);\n"); output_cpp "\t}\n"; in - let sctipt_name = tcpp_interface.if_name ^ "__scriptable" in + let script_name = tcpp_interface.if_name ^ "__scriptable" in - output_cpp ("class " ^ sctipt_name ^ " : public ::hx::Object {\n"); + output_cpp ("class " ^ script_name ^ " : public ::hx::Object {\n"); output_cpp "public:\n"; let list_iteri func in_list = @@ -200,82 +199,65 @@ let generate_managed_interface base_ctx tcpp_interface = in_list in - list_iteri dump_script_field tcpp_interface.if_virtual_functions; + list_iteri dump_script_field tcpp_interface.if_functions; output_cpp "};\n\n"; - let generate_script_function field scriptName callName = - match follow field.cf_type with - | TFun (args, return_type) when not (is_data_member field) -> - output_cpp ("\nstatic void CPPIA_CALL " ^ scriptName ^ "(::hx::CppiaCtx *ctx) {\n"); - let ret = - match cpp_type_of return_type with - | TCppScalar "bool" -> "b" - | _ -> CppCppia.script_signature return_type false in - if ret <> "v" then - output_cpp ("ctx->return" ^ CppCppia.script_type return_type false ^ "("); - - let signature = - output_cpp (tcpp_interface.if_name ^ "::" ^ callName ^ "(ctx->getThis()" ^ if List.length 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*)") args in - output_cpp ")"; - signature - in - - if ret <> "v" then output_cpp ")"; - 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 - let sigs = Hashtbl.create 0 in - match tcpp_interface.if_virtual_functions with + match tcpp_interface.if_functions with | [] -> output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" | _ -> - List.iter - (fun (f, _, _) -> - let s = generate_script_function f ("__s_" ^ f.cf_name) (keyword_remap f.cf_name) in - Hashtbl.add sigs f.cf_name s) - tcpp_interface.if_virtual_functions; + let sig_and_funcs = List.map generate_script_function tcpp_interface.if_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 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 tcpp_interface.if_class CInterface then - "0" - else "__s_" ^ f.cf_name ^ "" - in - output_cpp ("HXCPP_CPPIA_SUPER_ARG(" ^ superCall ^ ")"); - output_cpp " ),\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 (fun (f, _, _) -> dump_func f "false") tcpp_interface.if_virtual_functions; - output_cpp " ::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n"; + List.iter dump_func sig_and_funcs; + output_cpp "\t::hx::ScriptNamedFunction(0,0,0 HXCPP_CPPIA_SUPER_ARG(0) ) };\n"; - output_cpp ("\n\n" ^ tcpp_interface.if_name ^ " " ^ tcpp_interface.if_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")) - tcpp_interface.if_virtual_functions; - output_cpp "};\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 = + tcpp_interface.if_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 diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 64fe91a68a4..0ee9bb28266 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -353,16 +353,10 @@ let generate_source ctx = | TClassDecl class_def -> let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in - let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in let decl = match has_class_flag class_def CInterface with | true -> - let iface = { - if_class = class_def; - if_name = class_name class_def; - if_debug_level = debug_level; - if_virtual_functions = all_virtual_functions class_def; - } in + let iface = CppRetyper.tcpp_interface_from_tclass ctx class_def in if native_gen then (NativeInterface iface) else (ManagedInterface iface) | false -> let cls = CppRetyper.tcpp_class_from_tclass ctx self_id parent_ids class_def in From 916320b00c96c7590c0cf8fd0f76d33b1da21056 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 4 Nov 2024 23:07:32 +0000 Subject: [PATCH 51/97] store interface hash --- src/generators/cpp/cppAst.ml | 3 ++- src/generators/cpp/cppRetyper.ml | 1 + src/generators/cpp/gen/cppGenInterfaceHeader.ml | 2 +- src/generators/cpp/gen/cppGenInterfaceImplementation.ml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 7e8e8c56b84..49c0ff68243 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -204,8 +204,9 @@ and tcpp_interface_function = { and tcpp_interface = { if_class : tclass; if_name : string; + if_hash : string; if_debug_level : int; - if_functions : tcpp_interface_function list + if_functions : tcpp_interface_function list; } and tcpp_enum_field = { diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index f65a5e5d7ee..8b630453c17 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1632,6 +1632,7 @@ and tcpp_interface_from_tclass ctx class_def = { 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; } \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 65a5edac0ad..f71a52bada7 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -49,7 +49,7 @@ let gen_function ctx interface func = 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 (cpp_class_hash interface.if_class) func.iff_name (print_arg_names func.iff_args) |> output + 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 = diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 20a5f7e3bc9..65ada9a3173 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -269,7 +269,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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)" ^ cpp_class_hash tcpp_interface.if_class ^ " >;\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 scriptable then output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," ^ tcpp_interface.if_name ^ ");\n"); From 4c94f0fc01697d14f168e8a0f00955e311cad95a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 4 Nov 2024 23:19:32 +0000 Subject: [PATCH 52/97] store meta and rtti fields in remapped interface --- src/generators/cpp/cppAst.ml | 2 ++ src/generators/cpp/cppRetyper.ml | 7 ++++- .../cpp/gen/cppGenInterfaceImplementation.ml | 28 ++++++------------- 3 files changed, 17 insertions(+), 20 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 49c0ff68243..61049c89f92 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -207,6 +207,8 @@ and tcpp_interface = { if_hash : string; if_debug_level : int; if_functions : tcpp_interface_function list; + if_meta : texpr option; + if_rtti : texpr option; } and tcpp_enum_field = { diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 8b630453c17..5aeeb9460bb 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1628,11 +1628,16 @@ and tcpp_interface_from_tclass ctx class_def = } in let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in - let functions = class_def |> all_virtual_functions |> List.map retype_function in + let functions = class_def |> all_virtual_functions |> List.map retype_function 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 + { 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; + if_meta = meta_field; + if_rtti = rtti_field; } \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 65ada9a3173..0f27d6072e7 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -12,22 +12,6 @@ open CppSourceWriter open CppContext open CppGen -let gen_field_init ctx class_def field = - let dot_name = join_class_path class_def.cl_path "." in - let remap_name = keyword_remap field.cf_name in - - match field.cf_expr with - | Some expr -> - let var_name = - match remap_name with - | "__meta__" -> "__mClass->__meta__" - | "__rtti" -> "__mClass->__rtti__" - | _ -> remap_name - in - - gen_cpp_init ctx dot_name "boot" (var_name ^ " = ") expr - | _ -> () - let cpp_get_interface_slot ctx name = try Hashtbl.find !(ctx.ctx_interface_slot) name with Not_found -> @@ -278,9 +262,15 @@ let generate_managed_interface base_ctx tcpp_interface = if has_boot_field tcpp_interface.if_class then ( output_cpp ("void " ^ tcpp_interface.if_name ^ "::__boot()\n{\n"); - List.iter - (gen_field_init ctx tcpp_interface.if_class) - (List.filter should_implement_field tcpp_interface.if_class.cl_ordered_statics); + 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"); From 1c0bfce6500d79f7cef9de86aa19db0d99fbfc72 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 4 Nov 2024 23:27:06 +0000 Subject: [PATCH 53/97] dead code removal --- src/generators/cpp/gen/cppGenInterfaceHeader.ml | 7 +++---- .../cpp/gen/cppGenInterfaceImplementation.ml | 11 +---------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index f71a52bada7..963c85bf187 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -153,13 +153,12 @@ 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 parent, super = + let 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 - ( name, name ) + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) | None -> - ("", "::hx::Object") + "::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 diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 0f27d6072e7..7a253ce91c9 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -174,16 +174,7 @@ let generate_managed_interface base_ctx tcpp_interface = output_cpp ("class " ^ script_name ^ " : public ::hx::Object {\n"); output_cpp "public:\n"; - let list_iteri func in_list = - let idx = ref 0 in - List.iter - (fun elem -> - func !idx elem; - idx := !idx + 1) - in_list - in - - list_iteri dump_script_field tcpp_interface.if_functions; + ExtList.List.iteri dump_script_field tcpp_interface.if_functions; output_cpp "};\n\n"; let generate_script_function func = From 02e11ce73f962f2c9abaefccfd81783c72c93d04 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 5 Nov 2024 21:25:20 +0000 Subject: [PATCH 54/97] tcpp interfaces only store their functions --- src/generators/cpp/cppAst.ml | 2 + src/generators/cpp/cppAstTools.ml | 25 +++- src/generators/cpp/cppRetyper.ml | 119 +++++++++------- .../cpp/gen/cppGenInterfaceHeader.ml | 2 +- .../cpp/gen/cppGenInterfaceImplementation.ml | 128 +++++++++--------- 5 files changed, 160 insertions(+), 116 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 61049c89f92..9062abe90f5 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -207,6 +207,8 @@ and tcpp_interface = { if_hash : string; if_debug_level : int; if_functions : tcpp_interface_function list; + if_variables : tclass_field list; + if_implements : tcpp_interface list; if_meta : texpr option; if_rtti : texpr option; } diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 7faf78b986f..2bbede39f9e 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -736,4 +736,27 @@ let has_tcpp_class_flag c flag = has_flag c.tcl_flags (int_of_tcpp_class_flag flag) let cpp_interface_impl_name interface = - "_hx_" ^ join_class_path interface.cl_path "_" \ No newline at end of file + "_hx_" ^ join_class_path interface.cl_path "_" + +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_implements with + | [] -> existing + | some -> List.fold_left visit_interface existing some + in + + add_interface_functions initial interface + in + + visit_interface [] tcpp_interface |> List.rev \ No newline at end of file diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 5aeeb9460bb..5cc02962f7b 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1435,50 +1435,50 @@ let expression ctx request_type function_args function_type expression_tree forI let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = let filter_functions field = - let abstract_to_function () = - 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 - 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 - - if should_implement_field field then - match (field.cf_kind, field.cf_expr) with - | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (field, func) - | Method MethNormal, _ when has_class_field_flag field CfAbstract -> - Some (field, abstract_to_function ()) - | _ -> + let abstract_to_function () = + 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 + 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 + + if should_implement_field field then + match (field.cf_kind, field.cf_expr) with + | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> + Some (field, func) + | Method MethNormal, _ when has_class_field_flag field CfAbstract -> + Some (field, abstract_to_function ()) + | _ -> + None + else None - else - None - in + in let filter_dynamic_functions func_for_static_field field = if should_implement_field field then @@ -1619,25 +1619,40 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = and tcpp_interface_from_tclass ctx class_def = - let retype_function (field, args, ret) = - { - iff_field = field; - iff_name = keyword_remap field.cf_name; - iff_args = args; - iff_return = ret; - } in + let function_filter field = + match (field.cf_type, field.cf_kind) with + | TFun (args, ret), Method _ -> + Some { + iff_field = field; + iff_name = keyword_remap field.cf_name; + iff_args = args; + iff_return = ret; + } + | _ -> + None + 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 || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level in - let functions = class_def |> all_virtual_functions |> List.map retype_function 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 implements = + class_def.cl_implements + |> List.map (fun (t, _) -> tcpp_interface_from_tclass ctx t) + |> List.append (Option.map_default (fun (cls, _) -> [ tcpp_interface_from_tclass ctx cls ]) [] class_def.cl_super) in { 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; + if_functions = List.filter_map function_filter class_def.cl_ordered_fields; + if_variables = List.filter variable_filter class_def.cl_ordered_fields; if_meta = meta_field; if_rtti = rtti_field; + if_implements = implements; } \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 963c85bf187..8370085b026 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -90,7 +90,7 @@ let gen_header_includes interface_def output_h = 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"; - List.iter iter tcpp_interface.if_functions; + all_interface_functions tcpp_interface |> List.iter iter; match get_meta_string tcpp_interface.if_class.cl_meta Meta.ObjcProtocol with | Some protocol -> diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 7a253ce91c9..e1f25076577 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -20,9 +20,7 @@ let cpp_get_interface_slot ctx name = 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" in +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"; @@ -43,52 +41,49 @@ let generate_protocol_delegate ctx class_def output = 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" - | _ -> () + 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 class_def.cl_ordered_fields; + List.iter dump_delegate functions; output "@end\n\n" @@ -131,20 +126,29 @@ let generate_managed_interface base_ctx tcpp_interface = output_cpp "\n"; (* cl_interface *) - let implemented_instance_fields = List.filter should_implement_field tcpp_interface.if_class.cl_ordered_fields in - let reflective_members = List.filter (reflective tcpp_interface.if_class) implemented_instance_fields in + 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 = - match reflective_members with - | [] -> "0 /* sMemberFields */" - | _ -> + if List.length members > 1 then let memberFields = tcpp_interface.if_name ^ "_sMemberFields" in - let dump_field_name field = output_cpp ("\t" ^ strq field.cf_name ^ ",\n") in - output_cpp ("static ::String " ^ memberFields ^ "[] = {\n"); - List.iter dump_field_name reflective_members; - output_cpp "\t::String(null()) };\n\n"; + 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 scriptable then ( let dump_script_field idx func = let args = print_tfun_arg_list true func.iff_args in @@ -174,7 +178,7 @@ let generate_managed_interface base_ctx tcpp_interface = output_cpp ("class " ^ script_name ^ " : public ::hx::Object {\n"); output_cpp "public:\n"; - ExtList.List.iteri dump_script_field tcpp_interface.if_functions; + ExtList.List.iteri dump_script_field all_functions; output_cpp "};\n\n"; let generate_script_function func = @@ -206,11 +210,11 @@ let generate_managed_interface base_ctx tcpp_interface = (signature, func) in - match tcpp_interface.if_functions with + match all_functions with | [] -> output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" | _ -> - let sig_and_funcs = List.map generate_script_function tcpp_interface.if_functions in + 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"; @@ -228,7 +232,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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 = - tcpp_interface.if_functions + all_functions |> List.map mapper |> String.concat ",\n" in @@ -270,7 +274,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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 tcpp_interface.if_class output_cpp; + 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"); From 07ac0934448936938b256ce390a5c6a634f68abf Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 5 Nov 2024 21:54:33 +0000 Subject: [PATCH 55/97] remapped enum fields rename for consistency --- src/generators/cpp/cppAst.ml | 12 ++--- src/generators/cpp/gen/cppGenEnum.ml | 66 ++++++++++++++-------------- src/generators/gencpp.ml | 4 +- 3 files changed, 41 insertions(+), 41 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 9062abe90f5..fe833818e03 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -214,15 +214,15 @@ and tcpp_interface = { } and tcpp_enum_field = { - ef_field : tenum_field; - ef_remapped_name : string; - ef_hashed_name : string; + tef_field : tenum_field; + tef_name : string; + tef_hash : string; } and tcpp_enum = { - e_enum : tenum; - e_id : int32; - e_constructors : tcpp_enum_field list; + te_enum : tenum; + te_id : int32; + te_constructors : tcpp_enum_field list; } and tcpp_decl = diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 1f1ce35d92f..9266ba5ae68 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -18,10 +18,10 @@ let constructor_arg_count constructor = | _ -> 0 let gen_enum_constructor remap_class_name class_name output_cpp constructor = - match constructor.ef_field.ef_type with + match constructor.tef_field.ef_type with | TFun (args, _) -> - Printf.sprintf "%s %s::%s(%s)\n" remap_class_name class_name constructor.ef_remapped_name (print_tfun_arg_list true args) |> output_cpp; - Printf.sprintf "{\n\treturn ::hx::CreateEnum<%s>(%s,%i,%i)" class_name constructor.ef_hashed_name constructor.ef_field.ef_index (List.length args) |> output_cpp; + 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)) @@ -29,47 +29,47 @@ let gen_enum_constructor remap_class_name class_name output_cpp constructor = output_cpp ";\n}\n\n" | _ -> - output_cpp ( remap_class_name ^ " " ^ class_name ^ "::" ^ constructor.ef_remapped_name ^ ";\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.ef_field > 0 then "_dyn()" else "" in - Printf.sprintf "\tif (inName==%s) { outValue = %s::%s%s; return true; }\n" constructor.ef_hashed_name class_name constructor.ef_remapped_name dyn |> output_cpp + 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.ef_field in + 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.ef_remapped_name |> output_cpp; + 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.e_enum.e_path 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 tcpp_enum.e_enum.e_meta) || ( Common.defined common_ctx Define.NoDebug) then 0 else 1 in + let debug = if (Meta.has Meta.NoDebug tcpp_enum.te_enum.e_meta) || ( Common.defined common_ctx Define.NoDebug) then 0 else 1 in let ctx = file_context base_ctx cpp_file debug false in let strq = strq ctx.ctx_common in - let classIdTxt = Printf.sprintf "0x%08lx" tcpp_enum.e_id 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 "::" )); cpp_file#write_h "#include \n\n"; - let referenced,flags = CppReferences.find_referenced_types_flags ctx (TEnumDecl tcpp_enum.e_enum) None ctx.ctx_super_deps PathMap.empty 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"; - List.iter (gen_enum_constructor remap_class_name class_name output_cpp) tcpp_enum.e_constructors; + 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"); - List.iter (gen_static_reflection class_name output_cpp) tcpp_enum.e_constructors; + 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"); @@ -80,18 +80,18 @@ let generate base_ctx tcpp_enum = output_cpp ("int " ^ class_name ^ "::__FindIndex(::String inName)\n{\n"); List.iter - (fun constructor -> Printf.sprintf "\tif (inName==%s) return %i;\n" constructor.ef_hashed_name constructor.ef_field.ef_index |> output_cpp) - tcpp_enum.e_constructors; + (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 *) - List.iter (gen_dynamic_constructor class_name output_cpp) tcpp_enum.e_constructors; + List.iter (gen_dynamic_constructor class_name output_cpp) tcpp_enum.te_constructors; output_cpp ("int " ^ class_name ^ "::__FindArgCount(::String inName)\n{\n"); List.iter - (fun constructor -> Printf.sprintf "\tif (inName==%s) return %i;\n" constructor.ef_hashed_name (constructor_arg_count constructor.ef_field) |> output_cpp) - tcpp_enum.e_constructors; + (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"); @@ -99,15 +99,15 @@ let generate base_ctx tcpp_enum = (* 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 constructor = - output_cpp ("\tif (inName==" ^ constructor.ef_hashed_name ^ ") return " ^ constructor.ef_remapped_name ); - if ( (constructor_arg_count constructor.ef_field) > 0 ) then output_cpp "_dyn()"; + 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 - List.iter dump_constructor_test tcpp_enum.e_constructors; + 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"); - List.iter (fun constructor -> output_cpp ("\t" ^ constructor.ef_hashed_name ^ ",\n") ) tcpp_enum.e_constructors; + List.iter (fun constructor -> output_cpp ("\t" ^ constructor.tef_hash ^ ",\n") ) tcpp_enum.te_constructors; output_cpp "\t::String(null())\n};\n\n"; @@ -131,7 +131,7 @@ let generate base_ctx tcpp_enum = output_cpp "}\n\n"; output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); - (match Texpr.build_metadata common_ctx.basic (TEnumDecl tcpp_enum.e_enum) with + (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 @@ -139,12 +139,12 @@ let generate base_ctx tcpp_enum = List.iter (fun constructor -> - match constructor.ef_field.ef_type with + match constructor.tef_field.ef_type with | TFun (_,_) -> () | _ -> - Printf.sprintf "%s = ::hx::CreateConstEnum<%s>(%s, %i);\n" constructor.ef_remapped_name class_name constructor.ef_hashed_name constructor.ef_field.ef_index |> output_cpp) - tcpp_enum.e_constructors; + 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"); @@ -161,7 +161,7 @@ let generate base_ctx tcpp_enum = List.iter2 (fun r f -> gen_forward_decl h_file r f) referenced flags; - output_h ( get_code tcpp_enum.e_enum.e_meta Meta.HeaderCode ); + output_h ( get_code tcpp_enum.te_enum.e_meta Meta.HeaderCode ); begin_namespace output_h class_path; @@ -182,15 +182,15 @@ let generate base_ctx tcpp_enum = List.iter (fun constructor -> - Printf.sprintf "\t\tstatic %s %s" remap_class_name constructor.ef_remapped_name |> output_h; - match constructor.ef_field.ef_type with + Printf.sprintf "\t\tstatic %s %s" remap_class_name constructor.tef_name |> output_h; + match constructor.tef_field.ef_type with | TFun (args,_) -> Printf.sprintf "(%s);\n" (print_tfun_arg_list true args) |> output_h; - Printf.sprintf "\t\tstatic ::Dynamic %s_dyn();\n" constructor.ef_remapped_name |> output_h; + Printf.sprintf "\t\tstatic ::Dynamic %s_dyn();\n" constructor.tef_name |> output_h; | _ -> output_h ";\n"; - Printf.sprintf "\t\tstatic inline %s %s_dyn() { return %s; }\n" remap_class_name constructor.ef_remapped_name constructor.ef_remapped_name |> output_h;) - tcpp_enum.e_constructors; + 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/gencpp.ml b/src/generators/gencpp.ml index 0ee9bb28266..ea70661af8a 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -386,8 +386,8 @@ let generate_source ctx = let strq = strq ctx.ctx_common in let sort_constructors f1 f2 = f1.ef_index - f2.ef_index in - let constructors = enum_def.e_constrs |> pmap_values |> List.sort sort_constructors |> List.map (fun f -> { ef_field = f; ef_remapped_name = keyword_remap f.ef_name; ef_hashed_name = strq f.ef_name}) in - let acc_decls = (Enum { e_enum = enum_def; e_id = self_id; e_constructors = constructors }) :: acc.decls 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 acc_decls = (Enum { te_enum = enum_def; te_id = self_id; te_constructors = constructors }) :: 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 From 0da384096e9c05c03c04b6c8be81cdfa95c3d58c Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 7 Nov 2024 23:49:17 +0000 Subject: [PATCH 56/97] calculate interface slots ahead of time --- src/generators/cpp/cppAst.ml | 41 ++++++++++++++++- src/generators/cpp/cppAstTools.ml | 8 ++-- src/generators/cpp/cppContext.ml | 4 -- src/generators/cpp/cppRetyper.ml | 44 +++++++++++++------ src/generators/cpp/gen/cppGen.ml | 11 ++--- .../cpp/gen/cppGenInterfaceHeader.ml | 9 ++-- .../cpp/gen/cppGenInterfaceImplementation.ml | 20 ++++----- src/generators/gencpp.ml | 32 ++++---------- 8 files changed, 104 insertions(+), 65 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index fe833818e03..62d05c66d94 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -7,6 +7,43 @@ 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 @@ -199,6 +236,7 @@ and tcpp_interface_function = { iff_name : string; iff_args : (string * bool * t) list; iff_return : t; + iff_script_slot : int option; } and tcpp_interface = { @@ -208,9 +246,10 @@ and tcpp_interface = { if_debug_level : int; if_functions : tcpp_interface_function list; if_variables : tclass_field list; - if_implements : tcpp_interface list; + if_extends : tcpp_interface option; if_meta : texpr option; if_rtti : texpr option; + if_scriptable : bool; } and tcpp_enum_field = { diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 2bbede39f9e..08c0922b51f 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -751,9 +751,11 @@ let all_interface_functions tcpp_interface = let rec visit_interface existing interface = let initial = - match interface.if_implements with - | [] -> existing - | some -> List.fold_left visit_interface existing some + match interface.if_extends with + | None -> + existing + | Some super -> + visit_interface existing super in add_interface_functions initial interface diff --git a/src/generators/cpp/cppContext.ml b/src/generators/cpp/cppContext.ml index da7614b3025..74dc27d6c0b 100644 --- a/src/generators/cpp/cppContext.ml +++ b/src/generators/cpp/cppContext.ml @@ -27,8 +27,6 @@ type context = { 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; @@ -48,8 +46,6 @@ let new_context common_ctx debug file_info member_types super_deps constructor_d ctx_file_id = ref (-1); 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 diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 5cc02962f7b..1cbbe4e16cd 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1617,19 +1617,28 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = tcl_init = TClass.get_cl_init class_def; } -and tcpp_interface_from_tclass ctx class_def = +and tcpp_interface_from_tclass ctx slots class_def = - let function_filter field = + let scriptable = Common.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 _ -> - Some { + let slots = if scriptable then + CppAst.InterfaceSlots.add field.cf_name slots + else + slots + in + let retyped = { iff_field = field; iff_name = keyword_remap field.cf_name; iff_args = args; iff_return = ret; - } + iff_script_slot = CppAst.InterfaceSlots.find_opt field.cf_name slots + } in + (slots, retyped :: fields) | _ -> - None + (slots, fields) in let variable_filter field = match field.cf_kind with @@ -1640,19 +1649,28 @@ and tcpp_interface_from_tclass ctx class_def = let debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.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 implements = - class_def.cl_implements - |> List.map (fun (t, _) -> tcpp_interface_from_tclass ctx t) - |> List.append (Option.map_default (fun (cls, _) -> [ tcpp_interface_from_tclass ctx cls ]) [] class_def.cl_super) 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 = List.filter_map function_filter class_def.cl_ordered_fields; + 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_implements = implements; - } \ No newline at end of file + if_extends = extends; + if_scriptable = scriptable; + } in + + (slots, iface) \ No newline at end of file diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index a25d6d7e220..91ffaa18d57 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1649,7 +1649,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 @@ -1664,9 +1664,10 @@ let generate_boot ctx boot_enums boot_classes nonboot_classes init_classes = let newScriptable = Common.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"; @@ -1683,7 +1684,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 diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 8370085b026..07bebc3e1b6 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -69,11 +69,10 @@ let gen_includes h_file interface_def = |> real_interfaces |> List.iter (fun (cls, _) -> add_class_includes cls) -let gen_forward_decls h_file interface_def ctx common_ctx = +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 scriptable = Common.defined common_ctx Define.Scriptable && not interface_def.cl_private in let header_referenced, header_flags = - CppReferences.find_referenced_types_flags ctx (TClassDecl interface_def) None ctx.ctx_super_deps PathMap.empty true false scriptable + 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 @@ -121,7 +120,7 @@ let generate_native_interface base_ctx tcpp_interface = 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.if_class ctx common_ctx; + 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; @@ -168,7 +167,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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.if_class ctx common_ctx; + 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; diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index e1f25076577..e6b2c4c80db 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -12,13 +12,13 @@ open CppSourceWriter open CppContext open CppGen -let cpp_get_interface_slot ctx name = +(* 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 + result *) let generate_protocol_delegate ctx protocol full_class_name functions output = let name = "_hx_" ^ protocol ^ "_delegate" in @@ -88,14 +88,12 @@ let generate_protocol_delegate ctx protocol full_class_name functions output = output "@end\n\n" 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 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 - let scriptable = Common.defined common_ctx Define.Scriptable && not tcpp_interface.if_class.cl_private in if tcpp_interface.if_debug_level > 1 then print_endline @@ -105,11 +103,11 @@ let generate_managed_interface base_ctx tcpp_interface = let all_referenced = CppReferences.find_referenced_types ctx (TClassDecl tcpp_interface.if_class) ctx.ctx_super_deps - ctx.ctx_constructor_deps false false scriptable + ctx.ctx_constructor_deps false false tcpp_interface.if_scriptable in List.iter (add_include cpp_file) all_referenced; - if scriptable then cpp_file#write_h "#include \n"; + if tcpp_interface.if_scriptable then cpp_file#write_h "#include \n"; cpp_file#write_h "\n"; @@ -149,7 +147,7 @@ let generate_managed_interface base_ctx tcpp_interface = let all_functions = all_interface_functions tcpp_interface in - if scriptable then ( + 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 @@ -165,7 +163,7 @@ let generate_managed_interface base_ctx tcpp_interface = ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" ^ keyword_remap name ^ ");\n")) func.iff_args; - let interfaceSlot = string_of_int (-cpp_get_interface_slot ctx func.iff_name) in + 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 @@ -210,7 +208,7 @@ let generate_managed_interface base_ctx tcpp_interface = (signature, func) in - match all_functions with + (match all_functions with | [] -> output_cpp "static ::hx::ScriptNamedFunction *__scriptableFunctions = 0;\n" | _ -> @@ -228,7 +226,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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"; + 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 = @@ -250,7 +248,7 @@ let generate_managed_interface base_ctx tcpp_interface = 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 scriptable then + if tcpp_interface.if_scriptable then output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\"" ^ class_name_text ^ "\"," ^ tcpp_interface.if_name ^ ");\n"); output_cpp "}\n\n"; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index ea70661af8a..a6ac497cb68 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -246,21 +246,6 @@ let is_assign_op op = The common_ctx contains the haxe AST in the "types" field and the resources *) -module ObjectIds = struct - type t = (int32 PathMap.t * unit Int32Map.t) - - let empty = (PathMap.empty, Int32Map.empty) - - let add path id ((ids, cache):t) = - (PathMap.add path id ids, Int32Map.add id () cache) - - let find_opt path ((ids, _):t) = - PathMap.find_opt path ids - - let collision id ((_, cache):t) = - Int32Map.mem id cache -end - type gensrc_ctx = { extern_src : string list; build_xml : string; @@ -270,8 +255,8 @@ type gensrc_ctx = { boot_enums : path list; exe_classes : (path * path list * module_type) list; decls : tcpp_decl list; - - ids : ObjectIds.t; + ids : CppAst.ObjectIds.t; + slots : CppAst.InterfaceSlots.t; } let rec get_id path ids = @@ -328,6 +313,7 @@ let generate_source ctx = exe_classes = []; decls = []; ids = ObjectIds.empty; + slots = InterfaceSlots.empty; } in let folder acc cur = @@ -353,14 +339,14 @@ let generate_source ctx = | TClassDecl class_def -> let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in - let decl = + let decl, slots = match has_class_flag class_def CInterface with | true -> - let iface = CppRetyper.tcpp_interface_from_tclass ctx class_def in - if native_gen then (NativeInterface iface) else (ManagedInterface iface) + let (slots, iface) = CppRetyper.tcpp_interface_from_tclass ctx acc.slots class_def in + if native_gen then (NativeInterface iface, slots) else (ManagedInterface iface, slots) | false -> let cls = CppRetyper.tcpp_class_from_tclass ctx self_id parent_ids class_def in - if native_gen then (NativeClass cls) else (ManagedClass cls) in + if native_gen then (NativeClass cls, acc.slots) else (ManagedClass cls, acc.slots) in let acc_decls = decl :: acc.decls in let acc_build_xml = acc.build_xml ^ (CppGen.get_class_code class_def Meta.BuildXml) in @@ -375,7 +361,7 @@ let generate_source ctx = (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 = all_ids } + { 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 = all_ids; slots = slots } | TEnumDecl enum_def when is_extern_enum enum_def || is_internal_class enum_def.e_path -> acc @@ -424,7 +410,7 @@ let generate_source ctx = CppGen.generate_main ctx ctx.ctx_super_deps class_def ); - CppGen.generate_boot ctx srcctx.boot_enums srcctx.boot_classes srcctx.nonboot_classes srcctx.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; From f683ccd52b5e1b5ed611eef8d25fd845680075c5 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 7 Nov 2024 23:57:41 +0000 Subject: [PATCH 57/97] remap interface arg names --- src/generators/cpp/cppRetyper.ml | 8 ++++---- .../cpp/gen/cppGenInterfaceImplementation.ml | 11 +---------- 2 files changed, 5 insertions(+), 14 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 1cbbe4e16cd..e89b0742a48 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1630,10 +1630,10 @@ and tcpp_interface_from_tclass ctx slots class_def = slots in let retyped = { - iff_field = field; - iff_name = keyword_remap field.cf_name; - iff_args = args; - iff_return = ret; + iff_field = field; + iff_name = keyword_remap field.cf_name; + 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) diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index e6b2c4c80db..5921cedd6fb 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -12,14 +12,6 @@ open CppSourceWriter open CppContext open CppGen -(* 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 protocol full_class_name functions output = let name = "_hx_" ^ protocol ^ "_delegate" in output ("@interface " ^ name ^ " : NSObject<" ^ protocol ^ "> {\n"); @@ -160,8 +152,7 @@ let generate_managed_interface base_ctx tcpp_interface = List.iter (fun (name, opt, t) -> output_cpp - ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" - ^ keyword_remap name ^ ");\n")) + ("\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 From 0c69ea9f801203442486d2b1f352b640f963a3b5 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 8 Nov 2024 16:26:25 +0000 Subject: [PATCH 58/97] retype the interfaces stored on retyped classes --- src/generators/cpp/cppAst.ml | 4 +- src/generators/cpp/cppRetyper.ml | 83 +++++++++++-- src/generators/cpp/gen/cppGen.ml | 28 ++--- src/generators/cpp/gen/cppGenClassHeader.ml | 115 +++++++----------- .../cpp/gen/cppGenClassImplementation.ml | 102 +++++++--------- src/generators/gencpp.ml | 70 +++-------- 6 files changed, 193 insertions(+), 209 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 62d05c66d94..539dcd02fe5 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -213,8 +213,8 @@ and tcpp_class = { tcl_flags : int; tcl_debug_level : int; - tcl_haxe_interfaces : tclass list; - tcl_native_interfaces : tclass list; + tcl_haxe_interfaces : tcpp_interface list; + tcl_native_interfaces : tcpp_interface list; tcl_static_variables : tclass_field list; tcl_static_properties : tclass_field list; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index e89b0742a48..2c0abe811b1 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1433,7 +1433,45 @@ let expression ctx request_type function_args function_type expression_tree forI in retype request_type expression_tree -let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = +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 + + 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 get_class_ids class_def ids = + let self_id, all_ids = get_id class_def.cl_path ids in + + let folder (parents, all_ids) class_def = + let new_id, all_ids = get_id class_def.cl_path all_ids in + (new_id :: parents, all_ids) + in + let rec parents acc class_def = + match class_def.cl_super with + | Some (super, _) -> parents (super :: acc) super + | None -> acc in + let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in + + (self_id, parent_ids, all_ids) + +let rec tcpp_class_from_tclass ctx ids slots class_def = let filter_functions field = let abstract_to_function () = match field.cf_type with @@ -1518,7 +1556,9 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = Some field | _ -> None in - + + let self_id, parent_ids, ids = get_class_ids class_def ids in + let static_functions = class_def.cl_ordered_statics |> List.filter_map filter_functions in @@ -1554,23 +1594,24 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = |> List.filter_map filter_properties in (* All interfaces (and sub-interfaces) implemented *) - let rec folder (haxe, native) (interface, _) = + 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 (haxe, PathMap.add interface.cl_path interface native) interface.cl_implements + List.fold_left folder (slots, haxe, PathMap.add interface.cl_path retyped native) interface.cl_implements else - List.fold_left folder (PathMap.add interface.cl_path interface haxe, native) interface.cl_implements in + 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 (haxe, native) = - haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in + let values (slots, haxe, native) = + slots, haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in - let haxe_implementations, native_implementations = + let slots, haxe_implementations, native_implementations = class_def.cl_implements |> real_interfaces - |> List.fold_left folder (PathMap.empty, PathMap.empty) + |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) |> values in let flags = @@ -1595,7 +1636,7 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = 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_id = self_id; tcl_name = class_name class_def; @@ -1615,7 +1656,9 @@ let rec tcpp_class_from_tclass ctx self_id parent_ids class_def = 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 = @@ -1673,4 +1716,20 @@ and tcpp_interface_from_tclass ctx slots class_def = if_scriptable = scriptable; } in - (slots, iface) \ No newline at end of file + (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/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 91ffaa18d57..2a67930e40f 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -480,21 +480,21 @@ let gen_gc_name class_path = let needed_interface_functions implemented_instance_fields native_implementations = let have = implemented_instance_fields - |> List.map (fun field -> (field.cf_name, ())) - |> List.to_seq - |> Hashtbl.of_seq + |> List.map (fun (field, _) -> (field.cf_name, ())) + |> StringMap.of_list in - let want = ref [] in - List.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 + let func_folder (have, acc) func = + if StringMap.mem func.iff_field.cf_name have then + (have, acc) + else + (StringMap.add func.iff_field.cf_name () have, func :: acc) + in + let iface_folder acc iface = + List.fold_left func_folder acc iface.if_functions + in + 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 = diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index d39b0694d1f..707648f8ce7 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -308,92 +308,59 @@ let generate_managed_header base_ctx tcpp_class = output_h "\t\tvoid __Mark(HX_MARK_PARAMS);\n"; output_h "\t\tvoid __Visit(HX_VISIT_PARAMS);\n"); - let implements_haxe = List.length tcpp_class.tcl_haxe_interfaces > 0 in - let implements_native = List.length tcpp_class.tcl_native_interfaces > 0 in + if List.length tcpp_class.tcl_native_interfaces > 0 then ( + output_h "\n\t\tHX_NATIVE_IMPLEMENTATION\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 tcpp_class.tcl_native_interfaces - | false -> - [] - in + 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\t" ^ retVal ^ " " ^ func.iff_name ^ "( " ^ print_tfun_arg_list true func.iff_args ^ ") {\n"); + output_h + ("\t\t\t" ^ ret ^ "super::" ^ func.iff_name ^ "( " ^ String.concat "," argNames ^ ");\n\t\t}\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 ( + 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 = - 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 = match interface.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" 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") - | _ -> () + 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 class_def func.iff_field.cf_name interface.if_class + in + 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 - (match interface.cl_super with - | Some (super, _) -> check_interface super + (match interface.if_extends with + | Some super -> check_interface super | _ -> ()); - List.iter check_field interface.cl_ordered_fields + List.iter check_field interface.if_functions in check_interface src) tcpp_class.tcl_haxe_interfaces); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index ef1d597806d..54bc98ee44c 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -420,65 +420,57 @@ let generate_managed_class base_ctx tcpp_class = let implname = cpp_class_name class_def in let cpp_glue = ref [] in let iter interface = - let interface_name = cpp_interface_impl_name interface in + let interface_name = cpp_interface_impl_name interface.if_class in output_cpp - ("static " ^ cpp_class_name interface ^ " " ^ cname ^ "_" + ("static " ^ cpp_class_name interface.if_class ^ " " ^ 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 + let rec gen_interface_funcs (interface:tcpp_interface) = + let gen_field func = + let cast = cpp_tfun_signature false func.iff_args func.iff_return in + let class_implementation = find_class_implementation class_def func.iff_field.cf_name interface.if_class in + let realName = cpp_member_name_of func.iff_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" 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 returnStr = + if returnType = "void" then "" else "return " in - let implementationKey = - realName ^ "::" ^ class_implementation + let cppCode = + returnType ^ " " ^ class_name ^ "::" ^ glue ^ "(" + ^ argList ^ ") {\n" ^ "\t\t\t" ^ returnStr ^ realName + ^ "(" ^ print_arg_names func.iff_args ^ ");\n}\n" 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") - | _ -> () + (* 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) + (match interface.if_extends with + | Some super -> gen_interface_funcs super | _ -> ()); - List.iter gen_field interface.cl_ordered_fields + List.iter gen_field interface.if_functions in gen_interface_funcs interface; output_cpp "};\n\n" in @@ -492,7 +484,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\tswitch(inHash) {\n"; let iter interface = - output_cpp ("\t\tcase (int)" ^ cpp_class_hash interface ^ ": return &" ^ cname ^ "_" ^ cpp_interface_impl_name interface ^ ";\n") in + 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; @@ -1069,7 +1061,7 @@ let generate_managed_class base_ctx tcpp_class = (fun intf_def -> output_cpp ("\tHX_REGISTER_VTABLE_OFFSET( " ^ class_name ^ "," - ^ join_class_path_remap intf_def.cl_path "::" + ^ join_class_path_remap intf_def.if_class.cl_path "::" ^ ");\n")) tcpp_class.tcl_native_interfaces; output_cpp "}\n\n"; diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index a6ac497cb68..5d31a87f673 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -259,44 +259,6 @@ type gensrc_ctx = { slots : CppAst.InterfaceSlots.t; } -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 - - let rec make_id seed = - let id = 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 get_class_ids class_def ids = - let self_id, all_ids = get_id class_def.cl_path ids in - - let folder (parents, all_ids) class_def = - let new_id, all_ids = get_id class_def.cl_path all_ids in - (new_id :: parents, all_ids) - in - let rec parents acc class_def = - match class_def.cl_super with - | Some (super, _) -> parents (super :: acc) super - | None -> acc in - let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in - - (self_id, parent_ids, all_ids) - let generate_source ctx = let common_ctx = ctx.ctx_common in make_base_directory common_ctx.file; @@ -337,16 +299,15 @@ let generate_source ctx = acc | TClassDecl class_def -> - let self_id, parent_ids, all_ids = get_class_ids class_def acc.ids in - let native_gen = Meta.has Meta.NativeGen class_def.cl_meta in - let decl, slots = + 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) else (ManagedInterface iface, slots) + if native_gen then (NativeInterface iface, slots, acc.ids) else (ManagedInterface iface, acc.slots, acc.ids) | false -> - let cls = CppRetyper.tcpp_class_from_tclass ctx self_id parent_ids class_def in - if native_gen then (NativeClass cls, acc.slots) else (ManagedClass cls, acc.slots) in + 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 @@ -361,23 +322,28 @@ let generate_source ctx = (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 = all_ids; slots = slots } + { 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 self_id, all_ids = get_id enum_def.e_path acc.ids in let deps = CppReferences.find_referenced_types ctx (TEnumDecl enum_def) ctx.ctx_super_deps PathMap.empty false true false in - let strq = strq ctx.ctx_common in - let sort_constructors f1 f2 = - f1.ef_index - f2.ef_index 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 acc_decls = (Enum { te_enum = enum_def; te_id = self_id; te_constructors = constructors }) :: acc.decls 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 = all_ids } + { acc with decls = acc_decls; boot_enums = acc_boot_enums; exe_classes = acc_exe_classes; ids = ids } | _ -> acc in From 909cd5082dc80959144dfbbee0d4600724652e32 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 8 Nov 2024 17:52:04 +0000 Subject: [PATCH 59/97] retype tcpp_class supers --- src/generators/cpp/cppAst.ml | 2 +- src/generators/cpp/cppRetyper.ml | 51 ++++++++----------- .../cpp/gen/cppGenClassImplementation.ml | 11 +++- 3 files changed, 33 insertions(+), 31 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 539dcd02fe5..f0c622642b8 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -209,9 +209,9 @@ and tcpp_class = { tcl_class : tclass; tcl_name : string; tcl_id : int32; - tcl_parent_ids : int32 list; tcl_flags : int; tcl_debug_level : int; + tcl_super : tcpp_class option; tcl_haxe_interfaces : tcpp_interface list; tcl_native_interfaces : tcpp_interface list; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 2c0abe811b1..0cea0c3ea77 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1436,40 +1436,25 @@ let expression ctx request_type function_args function_type expression_tree forI 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 + (* 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 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 + 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) + (existing, ids) | None -> - let new_id = make_id 0 in - (new_id, ObjectIds.add path new_id ids) - -let get_class_ids class_def ids = - let self_id, all_ids = get_id class_def.cl_path ids in - - let folder (parents, all_ids) class_def = - let new_id, all_ids = get_id class_def.cl_path all_ids in - (new_id :: parents, all_ids) - in - let rec parents acc class_def = - match class_def.cl_super with - | Some (super, _) -> parents (super :: acc) super - | None -> acc in - let parent_ids, all_ids = parents [] class_def |> List.fold_left folder ([], all_ids) in - - (self_id, parent_ids, all_ids) + let new_id = make_id 0 in + (new_id, ObjectIds.add path new_id ids) let rec tcpp_class_from_tclass ctx ids slots class_def = let filter_functions field = @@ -1557,7 +1542,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = | _ -> None in - let self_id, parent_ids, ids = get_class_ids class_def ids in + let id, ids = get_id class_def.cl_path ids in let static_functions = class_def.cl_ordered_statics @@ -1608,6 +1593,14 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let values (slots, haxe, native) = slots, haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in + let (slots, ids, parent) = + match class_def.cl_super with + | Some (cls, _) -> + let slots, ids, parent = tcpp_class_from_tclass ctx ids slots cls in + (slots, ids, Some parent) + | None -> + (slots, ids, None) + in let slots, haxe_implementations, native_implementations = class_def.cl_implements |> real_interfaces @@ -1638,10 +1631,10 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let cls = { tcl_class = class_def; - tcl_id = self_id; + tcl_id = id; tcl_name = class_name class_def; tcl_flags = flags; - tcl_parent_ids = parent_ids; + tcl_super = parent; tcl_debug_level = if Meta.has Meta.NoDebug class_def.cl_meta || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; tcl_static_variables = static_variables; tcl_static_properties = static_properties; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 54bc98ee44c..a577a432bc0 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -392,7 +392,16 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn _hx_result;\n}\n\n"); output_cpp ("bool " ^ class_name ^ "::_hx_isInstanceOf(int inClassId) {\n"); - let implemented_classes = List.sort compare ((Int32.of_int 1) :: tcpp_class.tcl_id :: tcpp_class.tcl_parent_ids) in + 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 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 From 973b4be0510f30d75aa518ed7ae52535678a6728 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 8 Nov 2024 20:55:45 +0000 Subject: [PATCH 60/97] find_class_implementation uses tcpp_class --- src/generators/cpp/gen/cppGen.ml | 32 ++++++++----------- src/generators/cpp/gen/cppGenClassHeader.ml | 2 +- .../cpp/gen/cppGenClassImplementation.ml | 14 +++----- 3 files changed, 18 insertions(+), 30 deletions(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 2a67930e40f..0694588aa63 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -451,27 +451,21 @@ let cpp_tfun_signature include_names args return_type = 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.cf_name = func.iff_field.cf_name) def.tcl_functions with + | Some f -> Some (fst f) + | 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 diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 707648f8ce7..786295a271e 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -334,7 +334,7 @@ let generate_managed_header base_ctx tcpp_class = 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 class_def func.iff_field.cf_name interface.if_class + let class_implementation = find_class_implementation func tcpp_class in let realName = cpp_member_name_of func.iff_field in let castKey = realName ^ "::" ^ cast in diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index a577a432bc0..0483e160946 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -436,21 +436,15 @@ let generate_managed_class base_ctx tcpp_class = let rec gen_interface_funcs (interface:tcpp_interface) = let gen_field func = let cast = cpp_tfun_signature false func.iff_args func.iff_return in - let class_implementation = find_class_implementation class_def func.iff_field.cf_name interface.if_class in let realName = cpp_member_name_of func.iff_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 + let suffix = if interface_name = "_hx_haxe_IMap" && realName = "set" then "*" else "" in + let castKey = Printf.sprintf "%s::%s%s" realName cast suffix in + let implementationKey = Printf.sprintf "%s::%s" realName (find_class_implementation func tcpp_class) in if castKey <> implementationKey then ( let glue = Printf.sprintf "%s_%08lx" func.iff_field.cf_name (gen_hash32 0 cast) From 21744f938bb0f84492140fe1c0635aa19ee91097 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 9 Nov 2024 00:11:47 +0000 Subject: [PATCH 61/97] folds for class interface code --- .../cpp/gen/cppGenClassImplementation.ml | 111 ++++++++++-------- 1 file changed, 62 insertions(+), 49 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0483e160946..d0cb7f2356b 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -424,64 +424,77 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "}\n\n"; if List.length tcpp_class.tcl_haxe_interfaces > 0 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 - let iter interface = - let interface_name = cpp_interface_impl_name interface.if_class in - output_cpp - ("static " ^ cpp_class_name interface.if_class ^ " " ^ cname ^ "_" - ^ interface_name ^ "= {\n"); - let rec gen_interface_funcs (interface:tcpp_interface) = - let gen_field func = - let cast = cpp_tfun_signature false func.iff_args func.iff_return in - let realName = cpp_member_name_of func.iff_field in + let cname = "_hx_" ^ join_class_path class_def.cl_path "_" 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 = if interface_name = "_hx_haxe_IMap" && realName = "set" then "*" else "" in - let castKey = Printf.sprintf "%s::%s%s" realName cast suffix in - let implementationKey = Printf.sprintf "%s::%s" realName (find_class_implementation func tcpp_class) 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 returnStr = - if returnType = "void" then "" else "return " - in - let cppCode = - returnType ^ " " ^ class_name ^ "::" ^ glue ^ "(" - ^ argList ^ ") {\n" ^ "\t\t\t" ^ returnStr ^ realName - ^ "(" ^ print_arg_names func.iff_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")) + 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 - output_cpp - ("\t" ^ cast ^ "&" ^ implname ^ "::" ^ realName ^ ",\n") + 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 + + let initial = + match interface.if_extends with + | Some super -> gen_interface_funcs super + | _ -> (glued, []) in - (match interface.if_extends with - | Some super -> gen_interface_funcs super - | _ -> ()); - List.iter gen_field interface.if_functions + List.fold_left fold_field initial interface.if_functions in - gen_interface_funcs interface; - output_cpp "};\n\n" in - List.iter - iter - tcpp_class.tcl_haxe_interfaces; - output_cpp (String.concat "\n" !cpp_glue); + 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 + + let glued, calls = + List.fold_left + fold_interface + (StringMap.empty, []) + tcpp_class.tcl_haxe_interfaces in + + calls |> String.concat "\n" |> output_cpp; + glued |> StringMap.to_list |> List.map snd |> String.concat "\n" |> output_cpp; output_cpp ("void *" ^ class_name ^ "::_hx_getInterface(int inHash) {\n"); output_cpp "\tswitch(inHash) {\n"; From cd77345e44783a458986e6ee6b55242d02a07e91 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 9 Nov 2024 13:43:59 +0000 Subject: [PATCH 62/97] other minor cleanup --- src/generators/cpp/cppAstTools.ml | 27 +++++++++---------- src/generators/cpp/gen/cppGen.ml | 17 +++++------- .../cpp/gen/cppGenClassImplementation.ml | 5 +++- 3 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 08c0922b51f..8cd3304f08c 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -591,6 +591,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 *" @@ -603,17 +616,6 @@ 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 ) @@ -735,9 +737,6 @@ let int_of_tcpp_class_flag (flag:tcpp_class_flags) = let has_tcpp_class_flag c flag = has_flag c.tcl_flags (int_of_tcpp_class_flag flag) -let cpp_interface_impl_name interface = - "_hx_" ^ join_class_path interface.cl_path "_" - let all_interface_functions tcpp_interface = let add_interface_functions existing interface = let folder acc cur = diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 0694588aa63..249307abdc4 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -68,23 +68,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 + 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 + arg_list + |> List.map (fun (name, o, arg_type) -> (oType o arg_type) ^ (if include_names then " " ^ keyword_remap name else "")) + |> String.concat "," let has_new_gc_references class_def = let is_gc_reference field = diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index d0cb7f2356b..8f5e5345054 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -254,6 +254,9 @@ let print_reflective_fields ctx_common class_def variables functions = | concat -> Some (concat @ [ "\t::String(null())" ] |> String.concat ",\n") +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 @@ -424,7 +427,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "}\n\n"; if List.length tcpp_class.tcl_haxe_interfaces > 0 then ( - let cname = "_hx_" ^ join_class_path class_def.cl_path "_" in + let cname = cpp_interface_impl_name class_def in let impl_name = cpp_class_name class_def in let fold_interface (glued, acc) interface = From 36cd2e98bd5c2629cc52accd12424af3dcca26e4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 9 Nov 2024 23:50:15 +0000 Subject: [PATCH 63/97] use flags in class generation to selectively generate some funcs --- src/generators/cpp/cppAst.ml | 3 ++ src/generators/cpp/cppAstTools.ml | 3 ++ src/generators/cpp/cppRetyper.ml | 30 ++++++--------- src/generators/cpp/gen/cppGenClassHeader.ml | 37 ++++++++----------- .../cpp/gen/cppGenClassImplementation.ml | 16 ++++---- 5 files changed, 42 insertions(+), 47 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index f0c622642b8..a47efd13a9b 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -204,6 +204,9 @@ and tcpp_class_flags = | MemberSet | StaticGet | StaticSet + | GetFields + | Compare + | Boot and tcpp_class = { tcl_class : tclass; diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 8cd3304f08c..bb679cea81e 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -734,6 +734,9 @@ let enum_getter_type t = 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) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 0cea0c3ea77..d80948aec66 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1607,24 +1607,18 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) |> values in - let flags = - if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then - set_flag 0 (int_of_tcpp_class_flag Scriptable) - else - 0 - in - let flags = - if can_quick_alloc class_def then - set_flag flags (int_of_tcpp_class_flag QuickAlloc) - else - flags - in - let flags = - if List.exists (fun f -> not (cant_be_null f.cf_type)) variables then - set_flag flags (int_of_tcpp_class_flag Container) - else - flags - in + let flags = 0 + |> (fun f -> if Common.defined ctx.ctx_common Define.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 List.exists (fun f -> not (cant_be_null f.cf_type)) variables then set_tcpp_class_flag f Container 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 diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 786295a271e..d978b0c099e 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -167,7 +167,7 @@ let generate_native_header base_ctx tcpp_class = CppGen.generate_native_constructor ctx output_h class_def true; - 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"; tcpp_class.tcl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); @@ -278,26 +278,22 @@ let generate_managed_header base_ctx tcpp_class = 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 + if has_tcpp_class_flag tcpp_class MemberGet then output_h - "\t\t::hx::Val __Field(const ::String &inString, ::hx::PropertyAccess \ - inCallProp);\n"; - if has_get_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_set_member_field class_def then + "\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_set_static_field class_def then + "\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_get_fields class_def then - output_h "\t\tvoid __GetFields(Array< ::String> &outFields);\n"; - - if has_compare_field class_def then + "\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 @@ -365,12 +361,11 @@ let generate_managed_header base_ctx tcpp_class = check_interface src) tcpp_class.tcl_haxe_interfaces); - if has_init_field class_def then output_h "\t\tstatic void __init__();\n\n"; + 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"); + ("\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"; tcpp_class.tcl_static_functions |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 8f5e5345054..644b332d5db 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -172,7 +172,7 @@ let gen_field_init ctx class_def field = | _ -> () let gen_boot_field ctx output_cpp tcpp_class = - if has_boot_field tcpp_class.tcl_class then ( + 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 @@ -653,7 +653,7 @@ let generate_managed_class base_ctx tcpp_class = | _ -> type_to_string f.cf_type in - if has_get_member_field class_def then ( + 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; @@ -672,7 +672,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn super::__Field(inName,inCallProp);\n}\n\n"); ); - if has_get_static_field class_def then ( + 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; let var_printer ident = Printf.sprintf "outValue = %s; return true;" ident in @@ -688,7 +688,7 @@ let generate_managed_class base_ctx tcpp_class = dump_quick_field_test all_fields; output_cpp "\treturn false;\n}\n\n"); - if has_set_member_field class_def then ( + 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; let fold_variable field acc = @@ -740,7 +740,7 @@ let generate_managed_class base_ctx tcpp_class = dump_quick_field_test all_fields; output_cpp "\treturn super::__SetField(inName,inValue,inCallProp);\n}\n\n"); - if has_set_static_field class_def then ( + 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 field acc = @@ -786,7 +786,7 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "\treturn false;\n}\n\n"); (* For getting a list of data members (eg, for serialization) *) - if has_get_fields class_def then ( + if has_tcpp_class_flag tcpp_class GetFields then ( let append field acc = (strq field.cf_name |> Printf.sprintf "\toutFields->push(%s);") :: acc in let fields = @@ -1047,12 +1047,12 @@ let generate_managed_class base_ctx tcpp_class = output_cpp ("\t__mClass->mGetStaticField = &" ^ - if has_get_static_field class_def then class_name ^ "::__GetStatic;\n" + 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_set_static_field class_def then class_name ^ "::__SetStatic;\n" + 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"); From 41d63d4bd2161b7503a02adfd8c95efb1012657d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 10 Nov 2024 22:12:50 +0000 Subject: [PATCH 64/97] retype class functions --- src/generators/cpp/cppAst.ml | 20 ++- src/generators/cpp/cppRetyper.ml | 108 +++++++++------ src/generators/cpp/gen/cppGen.ml | 21 +-- src/generators/cpp/gen/cppGenClassHeader.ml | 64 +++++---- .../cpp/gen/cppGenClassImplementation.ml | 123 ++++++++---------- 5 files changed, 168 insertions(+), 168 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index a47efd13a9b..6e72f69eb6a 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -208,6 +208,18 @@ and tcpp_class_flags = | 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 = { tcl_class : tclass; tcl_name : string; @@ -221,13 +233,13 @@ and tcpp_class = { tcl_static_variables : tclass_field list; tcl_static_properties : tclass_field list; - tcl_static_functions : (tclass_field * tfunc) list; - tcl_static_dynamic_functions : (tclass_field * tfunc) list; + tcl_static_functions : tcpp_class_function list; + tcl_static_dynamic_functions : tcpp_class_function list; tcl_variables : tclass_field list; tcl_properties : tclass_field list; - tcl_functions : (tclass_field * tfunc) list; - tcl_dynamic_functions : (tclass_field * tfunc) list; + tcl_functions : tcpp_class_function list; + tcl_dynamic_functions : tcpp_class_function list; tcl_meta : texpr option; tcl_rtti : texpr option; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index d80948aec66..18ec3c8c3b7 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1456,47 +1456,73 @@ let rec get_id path ids = 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 = - let filter_functions field = - let abstract_to_function () = - 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 - 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 + let scriptable = Common.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 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 (field, func) + Some (create_function field func) | Method MethNormal, _ when has_class_field_flag field CfAbstract -> - Some (field, abstract_to_function ()) + (* 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 @@ -1507,10 +1533,10 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Method MethDynamic, Some { eexpr = TFunction func } -> - Some (field, 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 (field, func) + Some (create_function field func) | _ -> None else @@ -1546,7 +1572,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let static_functions = class_def.cl_ordered_statics - |> List.filter_map filter_functions in + |> List.filter_map (filter_functions true) in let static_dynamic_functions = class_def.cl_ordered_statics @@ -1564,7 +1590,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let functions = class_def.cl_ordered_fields - |> List.filter_map filter_functions in + |> List.filter_map (filter_functions true) in let dynamic_functions = class_def.cl_ordered_fields @@ -1608,7 +1634,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = |> values in let flags = 0 - |> (fun f -> if Common.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private then set_tcpp_class_flag f Scriptable else f) + |> (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 List.exists (fun f -> not (cant_be_null f.cf_type)) variables then set_tcpp_class_flag f Container else f) |> (fun f -> if has_get_member_field class_def then set_tcpp_class_flag f MemberGet else f) @@ -1661,7 +1687,7 @@ and tcpp_interface_from_tclass ctx slots class_def = in let retyped = { iff_field = field; - iff_name = keyword_remap field.cf_name; + 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 diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 249307abdc4..89ee43cfcab 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -365,17 +365,6 @@ 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 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)) @@ -448,8 +437,8 @@ exception FieldFound of tclass_field let find_class_implementation func tcpp_class = let rec find def = - match List.find_opt (fun (f, _) -> f.cf_name = func.iff_field.cf_name) def.tcl_functions with - | Some f -> Some (fst f) + 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 @@ -469,14 +458,14 @@ let gen_gc_name class_path = let needed_interface_functions implemented_instance_fields native_implementations = let have = implemented_instance_fields - |> List.map (fun (field, _) -> (field.cf_name, ())) + |> List.map (fun (func) -> (func.tcf_name, ())) |> StringMap.of_list in let func_folder (have, acc) func = - if StringMap.mem func.iff_field.cf_name have then + if StringMap.mem func.iff_name have then (have, acc) else - (StringMap.add func.iff_field.cf_name () have, func :: acc) + (StringMap.add func.iff_name () have, func :: acc) in let iface_folder acc iface = List.fold_left func_folder acc iface.if_functions diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index d978b0c099e..9b2a4f7635a 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -31,38 +31,32 @@ let gen_member_variable ctx class_def is_static field = "\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 remap_name tcpp_str get_ptr remap_name |> output;) -let gen_dynamic_function ctx class_def is_static field function_def = - let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in - let prefix = if is_static then "\t\tstatic " else "\t\t" in - - Printf.sprintf "%sinline ::Dynamic& %s_dyn() { return %s; }\n" prefix remap_name remap_name |> output - -let gen_member_function ctx class_def is_static field function_def = - let output = ctx.ctx_output in - let is_non_virtual = Meta.has Meta.NonVirtual field.cf_meta in - let is_virtual = not is_non_virtual in - let is_non_static = not is_static in - - if is_virtual && is_non_static then ( - let is_not_scriptable = not (Common.defined ctx.ctx_common Define.Scriptable) in - let is_external_member = not (is_internal_member field.cf_name) in - if is_not_scriptable && is_external_member then - let key = Printf.sprintf "%s.%s" (join_class_path class_def.cl_path ".") field.cf_name in +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 + + if func.tcf_is_virtual && not is_static then ( + if not func.tcf_is_scriptable && not func.tcf_is_external 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 -> output v | None -> () else output "virtual "); - let return_type = type_to_string function_def.tf_type 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 - let remap_name = native_field_name_remap is_static field in - let prefix = (if is_static then "\t\tstatic " else "\t\t") in - Printf.sprintf "%s%s %s(%s);\n" prefix return_type_str remap_name (print_arg_list function_def.tf_args "") |> output; + let prefix = (if is_static then "static" else "") in + (* let remap_name = native_field_name_remap is_static field in *) + Printf.sprintf "\t\t%s %s %s(%s);\n" prefix return_type_str func.tcf_name (print_arg_list func.tcf_func.tf_args "") |> output; - if (is_non_virtual || not (is_override field)) && reflective class_def field then - Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix remap_name |> output + if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then + Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix func.tcf_name |> output let gen_class_header ctx tcpp_class h_file scriptable parents = let class_path = tcpp_class.tcl_class.cl_path in @@ -170,22 +164,22 @@ let generate_native_header base_ctx tcpp_class = if has_tcpp_class_flag tcpp_class Boot then output_h "\t\tstatic void __boot();\n"; tcpp_class.tcl_static_functions - |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); + |> List.iter (gen_member_function ctx class_def true); tcpp_class.tcl_static_dynamic_functions - |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); + |> List.iter (gen_dynamic_function ctx class_def true); tcpp_class.tcl_static_variables - |> List.iter (fun field -> gen_member_variable ctx class_def true field); + |> List.iter (gen_member_variable ctx class_def true); tcpp_class.tcl_functions - |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); + |> List.iter (gen_member_function ctx class_def false); tcpp_class.tcl_dynamic_functions - |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); + |> 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); + |> List.iter (gen_member_variable ctx class_def false); output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; @@ -368,19 +362,19 @@ let generate_managed_header base_ctx tcpp_class = if has_tcpp_class_flag tcpp_class Boot then output_h "\t\tstatic void __boot();\n"; tcpp_class.tcl_static_functions - |> List.iter (fun (field, func) -> gen_member_function ctx class_def true field func); + |> List.iter (gen_member_function ctx class_def true); tcpp_class.tcl_static_dynamic_functions - |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def true field func); + |> List.iter (gen_dynamic_function ctx class_def true); tcpp_class.tcl_static_variables - |> List.iter (fun field -> gen_member_variable ctx class_def true field); + |> List.iter (gen_member_variable ctx class_def true); tcpp_class.tcl_functions - |> List.iter (fun (field, func) -> gen_member_function ctx class_def false field func); + |> List.iter (gen_member_function ctx class_def false); tcpp_class.tcl_dynamic_functions - |> List.iter (fun (field, func) -> gen_dynamic_function ctx class_def false field func); + |> 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); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 644b332d5db..06375d25a97 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -12,12 +12,11 @@ open CppSourceWriter open CppContext open CppGen -let gen_function ctx class_def class_name is_static (field, function_def) = +let gen_function ctx class_def class_name is_static (func:tcpp_class_function) = let output = ctx.ctx_output in - let nargs = string_of_int (List.length function_def.tf_args) in - let return_type_str = type_to_string function_def.tf_type in - let return_type = cpp_type_of function_def.tf_type in - let no_debug = Meta.has Meta.NoDebug field.cf_meta 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 needsWrapper t = @@ -28,43 +27,34 @@ let gen_function ctx class_def class_name is_static (field, function_def) = in (* 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 (" " ^ 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 field.cf_meta Meta.FunctionCode in - let tail_code = get_code field.cf_meta Meta.FunctionTailCode in + 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 field.cf_meta Meta.Native with + 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 function_def.tf_args "__o_" + ^ print_arg_list_name func.tcf_func.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; + gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func.tcf_func 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 (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 ^ "_" ^ remap_name in + 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 @@ -80,17 +70,13 @@ let gen_function ctx class_def class_name is_static (field, function_def) = | 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 (cpp::Struct< " ^ tcpp_to_string return_type ^ " >) ") | _ -> output "return "); if is_static then - output (class_name ^ "::" ^ remap_name ^ "(") + output (class_name ^ "::" ^ func.tcf_name ^ "(") else - output - ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" - ^ remap_name ^ "("); + output ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" ^ func.tcf_name ^ "("); let cast_prefix arg = match arg with @@ -114,37 +100,33 @@ let gen_function ctx class_def class_name is_static (field, function_def) = output "}\n"; let nName = string_of_int (List.length tcpp_args) in output - ("::Dynamic " ^ class_name ^ "::" ^ remap_name - ^ "_dyn() {\n\treturn "); + ("::Dynamic " ^ class_name ^ "::" ^ func.tcf_name ^ "_dyn() {\n\treturn "); if is_static then output - ("::hx::CreateStaticFunction" ^ nName ^ "(\"" ^ remap_name - ^ "\"," ^ wrapName ^ ");") + ("::hx::CreateStaticFunction" ^ nName ^ "(\"" ^ func.tcf_name ^ "\"," ^ wrapName ^ ");") else output - ("::hx::CreateMemberFunction" ^ nName ^ "(\"" ^ remap_name - ^ "\",this," ^ wrapName ^ ");"); + ("::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%s(%s, %s, %s)\n\n" prefix nargs class_name remap_name ret |> output + 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 (field, function_def) = +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 remap_name = keyword_remap field.cf_name in - let func_name = "__default_" ^ remap_name in - let nargs = string_of_int (List.length function_def.tf_args) in - let return_type_str = type_to_string function_def.tf_type in - let return_type = cpp_type_of function_def.tf_type in - let no_debug = Meta.has Meta.NoDebug field.cf_meta 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 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 function_def.tf_args "__o_") |> 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 function_def "" "" no_debug; + 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" @@ -188,8 +170,7 @@ let gen_boot_field ctx output_cpp tcpp_class = List.iter (gen_field_init ctx tcpp_class.tcl_class) tcpp_class.tcl_static_variables; tcpp_class.tcl_static_dynamic_functions - |> List.map fst - |> List.iter (gen_field_init ctx tcpp_class.tcl_class); + |> List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcf_field); output_cpp "}\n\n") @@ -206,9 +187,8 @@ let gen_dynamic_function_allocator ctx output_cpp tcpp_class = match tcpp_class.tcl_dynamic_functions with | [] -> () | functions -> - let mapper (field, _) = - let name = keyword_remap field.cf_name in - Printf.sprintf "\tif (!_hx_obj->%s.mPtr) { _hx_obj->%s = new __default_%s(_hx_obj); }" name name name in + 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 @@ -239,9 +219,9 @@ let print_reflective_fields ctx_common class_def variables functions = Some (Printf.sprintf "\t%s" (strq field.cf_name)) else None in - let filter_funcs (field, _) = - if reflective class_def field then - Some (Printf.sprintf "\t%s" (strq field.cf_name)) + let filter_funcs func = + if func.tcf_is_reflective then + Some (Printf.sprintf "\t%s" (strq func.tcf_field.cf_name)) else None in @@ -541,9 +521,7 @@ let generate_managed_class base_ctx tcpp_class = (* Initialise non-static variables *) output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); List.iter - (fun (field, _) -> - let name = keyword_remap field.cf_name in - output_cpp ("\t" ^ name ^ " = new __default_" ^ name ^ "(this);\n")) + (fun func -> output_cpp ("\t" ^ func.tcf_name ^ " = new __default_" ^ func.tcf_name ^ "(this);\n")) tcpp_class.tcl_dynamic_functions; output_cpp "}\n\n"; @@ -627,11 +605,12 @@ let generate_managed_class base_ctx tcpp_class = acc in - let print_function printer (field, _) acc = - if (reflective class_def field) then - let ident = keyword_remap field.cf_name |> get_wrapper field 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 - (field.cf_name, String.length field.cf_name, printer ident) :: acc + (func.tcf_field.cf_name, length, ident) :: acc else acc in @@ -956,10 +935,10 @@ let generate_managed_class base_ctx tcpp_class = output_cpp (" typedef " ^ class_name ^ " super;\n"); let has_funky_toString = List.exists - (fun (f, _) -> f.cf_name = "toString") + (fun func -> func.tcf_name = "toString") tcpp_class.tcl_static_functions || List.exists - (fun (f, tfunc) -> f.cf_name = "toString" && List.length tfunc.tf_args <> 0) + (fun func -> func.tcf_name = "toString" && List.length func.tcf_func.tf_args <> 0) tcpp_class.tcl_functions in let super_string = @@ -978,14 +957,14 @@ let generate_managed_class base_ctx tcpp_class = 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 ("__s_" ^ f.cf_name) (keyword_remap f.cf_name) in - let superCall = if is_static then "0" else "__s_" ^ f.cf_name ^ "" in + 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.cf_name - f.cf_name + f.tcf_field.cf_name + f.tcf_field.cf_name signature (if is_static then "true" else "false") superCall in From 5f7b93a4e2bf9ba1c736f8bb35fe38b41fa284ea Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 10 Nov 2024 23:00:15 +0000 Subject: [PATCH 65/97] retype class variables --- src/generators/cpp/cppAst.ml | 19 ++- src/generators/cpp/cppRetyper.ml | 21 ++- src/generators/cpp/gen/cppGenClassHeader.ml | 19 ++- .../cpp/gen/cppGenClassImplementation.ml | 135 +++++++++--------- 4 files changed, 104 insertions(+), 90 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 6e72f69eb6a..7df9b43056a 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -220,6 +220,17 @@ and tcpp_class_function = { 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_name : string; @@ -231,13 +242,13 @@ and tcpp_class = { tcl_haxe_interfaces : tcpp_interface list; tcl_native_interfaces : tcpp_interface list; - tcl_static_variables : tclass_field list; - tcl_static_properties : tclass_field 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 : tclass_field list; - tcl_properties : tclass_field 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; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 18ec3c8c3b7..211ad3ddc98 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1477,6 +1477,17 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = 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 @@ -1547,14 +1558,14 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = if is_physical_field field then match (field.cf_kind, field.cf_expr) with | Var _, _ -> - Some field + Some (create_variable field) (* Dynamic methods are implemented as a physical field holding a closure *) | Method MethDynamic, Some { eexpr = TFunction func } -> - Some { field with cf_expr = None; cf_kind = Var ({ v_read = AccNormal; v_write = AccNormal }) } + 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 field + Some (create_variable field) | _ -> None else @@ -1564,7 +1575,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let filter_properties field = match field.cf_kind with | Var _ when not (is_physical_var_field field) -> - Some field + Some (create_variable field) | _ -> None in @@ -1636,7 +1647,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = 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 List.exists (fun f -> not (cant_be_null f.cf_type)) variables then set_tcpp_class_flag f Container else f) + |> (fun f -> if List.exists (fun v -> not (cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container 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) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 9b2a4f7635a..772221ef60f 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -12,24 +12,23 @@ open CppSourceWriter open CppContext open CppGen -let gen_member_variable ctx class_def is_static field = - let tcpp = cpp_type_of field.cf_type in +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 && only_stack_access field.cf_type 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) field.cf_pos; + 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 suffix = if is_static then "\t\tstatic " else "\t\t" in + let output = ctx.ctx_output in + let suffix = if is_static then "\t\tstatic " else "\t\t" in - Printf.sprintf "%s%s %s;\n" suffix tcpp_str remap_name |> output; + Printf.sprintf "%s%s %s;\n" suffix tcpp_str var.tcv_name |> output; - if not is_static && is_gc_element ctx tcpp then ( + 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 remap_name tcpp_str get_ptr remap_name |> output;) + 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 diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 06375d25a97..a025da128d0 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -12,7 +12,7 @@ open CppSourceWriter open CppContext open CppGen -let gen_function ctx class_def class_name is_static (func:tcpp_class_function) = +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 @@ -131,11 +131,9 @@ let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (f output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); output "HX_END_DEFAULT_FUNC\n\n" -let gen_static_variable ctx class_def class_name field = +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 - gen_type ctx field.cf_type; - output (" " ^ class_name ^ "::" ^ remap_name ^ ";\n\n") + Printf.sprintf "%s %s::%s;\n\n" (type_to_string var.tcv_type) class_name var.tcv_name |> output let gen_field_init ctx class_def field = let dot_name = join_class_path class_def.cl_path "." in @@ -167,10 +165,8 @@ let gen_boot_field ctx output_cpp tcpp_class = | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__rtti__ = " expr | None -> ()); - List.iter (gen_field_init ctx tcpp_class.tcl_class) tcpp_class.tcl_static_variables; - - tcpp_class.tcl_static_dynamic_functions - |> List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcf_field); + List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcv_field) tcpp_class.tcl_static_variables; + List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcf_field) tcpp_class.tcl_static_dynamic_functions; output_cpp "}\n\n") @@ -214,9 +210,9 @@ let gen_dynamic_function_allocator ctx output_cpp tcpp_class = let print_reflective_fields ctx_common class_def variables functions = let strq = strq ctx_common in - let filter_vars field = - if reflective class_def field then - Some (Printf.sprintf "\t%s" (strq field.cf_name)) + let filter_vars var = + if var.tcv_is_reflective then + Some (Printf.sprintf "\t%s" (strq var.tcv_field.cf_name)) else None in let filter_funcs func = @@ -528,8 +524,8 @@ let generate_managed_class base_ctx tcpp_class = if has_tcpp_class_flag tcpp_class Container then ( let super_needs_iteration = find_next_super_iteration class_def in let smart_class_name = snd class_path in - let dump_field_iterator macro field = - Printf.sprintf "\t%s(%s, \"%s\");\n" macro (keyword_remap field.cf_name) field.cf_name |> output_cpp + 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 (* MARK function - explicitly mark all child pointers *) @@ -589,18 +585,18 @@ let generate_managed_class base_ctx tcpp_class = value in - let print_variable var_printer get_printer field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let variable = keyword_remap field.cf_name |> get_wrapper field in + 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 field.cf_kind with + match var.tcv_field.cf_kind with | Var { v_read = AccCall } -> - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in + let prop_check = checkPropCall var.tcv_field in + let getter = Printf.sprintf "get_%s()" var.tcv_name |> get_wrapper var.tcv_field in - (field.cf_name, String.length field.cf_name, get_printer prop_check getter variable) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, get_printer prop_check getter variable) :: acc | _ -> - (field.cf_name, String.length field.cf_name, var_printer variable) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, var_printer variable) :: acc else acc in @@ -615,11 +611,11 @@ let generate_managed_class base_ctx tcpp_class = acc in - let print_property printer field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let prop_check = checkPropCall field in - let getter = keyword_remap field.cf_name |> Printf.sprintf "get_%s()" |> get_wrapper field in - (field.cf_name, String.length field.cf_name, printer prop_check getter) :: acc + 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_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 @@ -670,42 +666,40 @@ let generate_managed_class base_ctx tcpp_class = 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; - let fold_variable field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let ident = keyword_remap field.cf_name in - let casted = castable field in - let default = if is_gc_element ctx (cpp_type_of field.cf_type) then - Printf.sprintf "_hx_set_%s(HX_CTX_GET, inValue.Cast< %s >()); return inValue;" ident casted + 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;" ident casted in + Printf.sprintf "%s = inValue.Cast< %s >(); return inValue;" var.tcv_name casted in - match field.cf_kind with + match var.tcv_field.cf_kind with | Var { v_write = AccCall } -> - let prop_call = checkPropCall field in - let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_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 - (field.cf_name, String.length field.cf_name, call) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc | Var { v_write = AccNormal | AccNo | AccNever } -> - (field.cf_name, String.length field.cf_name, default) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, default) :: acc | _ -> acc else acc in - let fold_property field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let ident = keyword_remap field.cf_name in - let casted = castable field in + 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 field.cf_kind with + match var.tcv_field.cf_kind with | Var { v_write = AccCall } -> - let prop_call = checkPropCall field in - let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_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 - (field.cf_name, String.length field.cf_name, call) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc | _ -> acc else @@ -722,35 +716,34 @@ let generate_managed_class base_ctx tcpp_class = 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 field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - let ident = keyword_remap field.cf_name in - let casted = castable field 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 - match field.cf_kind with + match var.tcv_field.cf_kind with | Var { v_write = AccCall } -> - let prop_call = checkPropCall field in - let setter = ident |> Printf.sprintf "set_%s" |> get_wrapper field in - let call = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted ident casted in + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_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 - (field.cf_name, String.length field.cf_name, call) :: acc + (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc | Var { v_write = AccNormal | AccNo } -> - (field.cf_name, String.length field.cf_name, Printf.sprintf "%s = ioValue.Cast< %s >(); return true;" ident casted) :: acc + (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 - let fold_property field acc = - if (reflective class_def field) && not (is_abstract_impl class_def) then - match field.cf_kind with + 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 field in - let setter = keyword_remap field.cf_name |> Printf.sprintf "set_%s" |> get_wrapper field in - let casted = castable field in + let prop_call = checkPropCall var.tcv_field in + let setter = Printf.sprintf "set_%s" var.tcv_name |> get_wrapper var.tcv_field in + let casted = castable var.tcv_field in - (field.cf_name, String.length field.cf_name, Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); }" prop_call setter casted) :: acc + (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 @@ -767,7 +760,7 @@ let generate_managed_class base_ctx tcpp_class = (* For getting a list of data members (eg, for serialization) *) if has_tcpp_class_flag tcpp_class GetFields then ( - let append field acc = (strq field.cf_name |> Printf.sprintf "\toutFields->push(%s);") :: acc in + 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 @@ -786,12 +779,12 @@ let generate_managed_class base_ctx tcpp_class = "::hx::fsObject" ^ " /* " ^ tcpp_to_string o ^ " */ " | u -> "::hx::fsUnknown" ^ " /* " ^ tcpp_to_string u ^ " */ " in - let dump_member_storage field = + let dump_member_storage (var:tcpp_class_variable) = Printf.sprintf - "\t{ %s, (int)offsetof(%s, %s), %s },\n" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp + "\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 dump_static_storage field = - Printf.sprintf "\t{ %s, (void*) &%s::%s, %s },\n" (storage field) class_name (keyword_remap field.cf_name) (strq field.cf_name) |> output_cpp + 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 output_cpp "#ifdef HXCPP_SCRIPTABLE\n"; @@ -819,8 +812,8 @@ let generate_managed_class base_ctx tcpp_class = 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 field = - Printf.sprintf "\t%s(%s::%s, \"%s\");" macro class_name (keyword_remap field.cf_name) field.cf_name + 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 (* Mark static variables as used *) From 554d2fae051bfabcc9c59351452d83821afb4a92 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 10 Nov 2024 23:18:22 +0000 Subject: [PATCH 66/97] dedicated var and dyn function boot functions --- .../cpp/gen/cppGenClassImplementation.ml | 25 ++++++++----------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index a025da128d0..036535cb5c4 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -135,20 +135,17 @@ let gen_static_variable ctx class_def class_name (var:tcpp_class_variable) = let output = ctx.ctx_output in Printf.sprintf "%s %s::%s;\n\n" (type_to_string var.tcv_type) class_name var.tcv_name |> output -let gen_field_init ctx class_def field = - let dot_name = join_class_path class_def.cl_path "." in - let output = ctx.ctx_output in - let remap_name = keyword_remap field.cf_name in - - 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 -> - gen_cpp_init ctx dot_name "boot" (remap_name ^ " = ") expr + 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 = @@ -165,8 +162,8 @@ let gen_boot_field ctx output_cpp tcpp_class = | Some expr -> gen_cpp_init ctx dot_name "boot" "__mClass->__rtti__ = " expr | None -> ()); - List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcv_field) tcpp_class.tcl_static_variables; - List.iter (fun f -> gen_field_init ctx tcpp_class.tcl_class f.tcf_field) tcpp_class.tcl_static_dynamic_functions; + 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") From 399b7deca6cc08bc45de4af21f23aa6a81828691 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 12:38:48 +0000 Subject: [PATCH 67/97] dead code cleanup --- src/generators/cpp/cppExprUtils.ml | 24 ----------- src/generators/cpp/cppRetyper.ml | 1 - src/generators/cpp/cppTypeUtils.ml | 40 ++++--------------- src/generators/cpp/gen/cppCppia.ml | 14 ++++++- src/generators/cpp/gen/cppGen.ml | 11 ----- src/generators/cpp/gen/cppGenClassHeader.ml | 1 - .../cpp/gen/cppGenClassImplementation.ml | 1 - src/generators/cpp/gen/cppGenEnum.ml | 1 - .../cpp/gen/cppGenInterfaceHeader.ml | 1 - .../cpp/gen/cppGenInterfaceImplementation.ml | 1 - src/generators/cpp/gen/cppReferences.ml | 1 - src/generators/gencpp.ml | 1 - 12 files changed, 21 insertions(+), 76 deletions(-) delete mode 100644 src/generators/cpp/cppExprUtils.ml diff --git a/src/generators/cpp/cppExprUtils.ml b/src/generators/cpp/cppExprUtils.ml deleted file mode 100644 index 2bb10e72be6..00000000000 --- a/src/generators/cpp/cppExprUtils.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Extlib_leftovers -open Ast -open Type -open Error -open Common -open Globals - -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 \ No newline at end of file diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 211ad3ddc98..54ddcd41ad7 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -4,7 +4,6 @@ open Type open Error open Common open Globals -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index f06a674ee5d..8d70bbc9bff 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -70,17 +70,15 @@ 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 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 = + 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 = @@ -155,11 +153,6 @@ let is_numeric t = | _ -> 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 @@ -203,23 +196,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 = diff --git a/src/generators/cpp/gen/cppCppia.ml b/src/generators/cpp/gen/cppCppia.ml index 7a0dc0dd476..f97dc2863fb 100644 --- a/src/generators/cpp/gen/cppCppia.ml +++ b/src/generators/cpp/gen/cppCppia.ml @@ -4,7 +4,6 @@ open Type open Error open Common open Globals -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools @@ -356,6 +355,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 diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 89ee43cfcab..fbc0e9b61f0 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools @@ -365,14 +364,6 @@ 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 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 - let can_inline_constructor base_ctx class_def = match class_def.cl_constructor with | Some { cf_expr = Some super_func } -> @@ -433,8 +424,6 @@ 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 func tcpp_class = let rec find def = match List.find_opt (fun f -> f.tcf_name = func.iff_name) def.tcl_functions with diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 772221ef60f..8ff96ef5a51 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 036535cb5c4..247cc3fa4f6 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 9266ba5ae68..d758fc0d1d0 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 07bebc3e1b6..47d45db7d30 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 5921cedd6fb..180ede3032e 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index 6c9fa5b785f..cb816b05f77 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -4,7 +4,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 5d31a87f673..33e816d37d5 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -22,7 +22,6 @@ open Error open Common open Globals open CppStrings -open CppExprUtils open CppTypeUtils open CppAst open CppAstTools From d28a3bd5e480642f0f78389baac2e1165f258d8d Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 14:04:16 +0000 Subject: [PATCH 68/97] use bindings instead of to_list --- src/generators/cpp/cppRetyper.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 54ddcd41ad7..055ca8beddd 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1627,7 +1627,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = | None -> acc in let values (slots, haxe, native) = - slots, haxe |> PathMap.to_list |> List.map (fun (_, v) -> v), native |> PathMap.to_list |> List.map (fun (_, v) -> v) in + 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 From a1dff50e2ef496911d9028715c52c16e873e89ee Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 14:11:32 +0000 Subject: [PATCH 69/97] own implementation of of_list --- src/generators/cpp/gen/cppGen.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index fbc0e9b61f0..b81a35854f5 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -445,10 +445,12 @@ let gen_gc_name class_path = const_char_star class_name_text let needed_interface_functions implemented_instance_fields native_implementations = + let of_list bs = List.fold_left (fun m (k, v) -> StringMap.add k v m) StringMap.empty bs in + let have = implemented_instance_fields |> List.map (fun (func) -> (func.tcf_name, ())) - |> StringMap.of_list + |> of_list in let func_folder (have, acc) func = if StringMap.mem func.iff_name have then From c5b4c62b312f214affbdb9e968a37db7d9c2e849 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 14:18:11 +0000 Subject: [PATCH 70/97] replace another to_list --- src/generators/cpp/gen/cppGenClassImplementation.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 247cc3fa4f6..e5f856013d8 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -469,7 +469,7 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_haxe_interfaces in calls |> String.concat "\n" |> output_cpp; - glued |> StringMap.to_list |> List.map snd |> String.concat "\n" |> output_cpp; + glued |> StringMap.bindings |> List.map snd |> String.concat "\n" |> output_cpp; output_cpp ("void *" ^ class_name ^ "::_hx_getInterface(int inHash) {\n"); output_cpp "\tswitch(inHash) {\n"; From 0a0ad1afdb2862c2cc241be6488d670c1d4dbe28 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 16:46:57 +0000 Subject: [PATCH 71/97] Fix pointer and struct wrapping --- .../cpp/gen/cppGenClassImplementation.ml | 21 ++++++++----------- 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index e5f856013d8..5a9cd824a7c 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -58,8 +58,7 @@ let gen_function ctx class_def class_name is_static func = let initial = if is_static then [] else [ "::hx::Object *obj" ] in - initial - |> List.append (List.init (List.length tcpp_args) (fun idx -> Printf.sprintf "const ::Dynamic &a%i" idx)) + initial @ (List.init (List.length tcpp_args) (fun idx -> Printf.sprintf "const ::Dynamic &a%i" idx)) |> String.concat "," |> output; @@ -77,19 +76,17 @@ let gen_function ctx class_def class_name is_static func = else output ("reinterpret_cast< " ^ class_name ^ " *>(obj)->" ^ func.tcf_name ^ "("); - let cast_prefix arg = + let cast_prefix idx arg = match arg with | TCppStar (t, const) -> - Printf.sprintf "(::cpp::%sPointer< %s >)" (if const then "Const" else "") (tcpp_to_string arg) + 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 >)" (tcpp_to_string arg) + Printf.sprintf "(::cpp::Struct< %s >) a%i" (tcpp_to_string arg) idx | _ -> - "" in + Printf.sprintf "a%i" idx in + tcpp_args - |> List.map cast_prefix - |> List.map2 - (fun prefix arg -> prefix ^ arg) - (List.init (List.length tcpp_args) (fun idx -> Printf.sprintf "a%i" idx)) + |> ExtList.List.mapi cast_prefix |> String.concat ", " |> output; @@ -574,9 +571,9 @@ let generate_managed_class base_ctx tcpp_class = 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 + Printf.sprintf "(::cpp::Struct< %s >) %s" (tcpp_to_string inst) value | TCppStar _ -> - Printf.sprintf "::cpp::Pointer( %s )" value + Printf.sprintf "(::cpp::Pointer) %s" value | _ -> value in From 317b0cd05ed9a673b3eadeb3d8a4e16ea2545d46 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 11 Nov 2024 19:18:42 +0000 Subject: [PATCH 72/97] fix debug level not being reset between classes --- src/generators/cpp/gen/cppGenClassImplementation.ml | 12 ++++-------- .../cpp/gen/cppGenInterfaceImplementation.ml | 4 ---- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 5a9cd824a7c..fe79093614f 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -43,7 +43,10 @@ let gen_function ctx class_def class_name is_static func = ^ ");\n"); output "}\n\n" | _ -> - gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func.tcf_func code tail_code no_debug; + 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"; @@ -236,10 +239,6 @@ let generate_native_class base_ctx tcpp_class = let output_cpp = cpp_file#write in let scriptable = has_tcpp_class_flag tcpp_class Scriptable 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 all_referenced = @@ -302,9 +301,6 @@ let generate_managed_class base_ctx tcpp_class = 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"; diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 180ede3032e..b2d8a71f43d 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -86,10 +86,6 @@ let generate_managed_interface base_ctx tcpp_interface = let output_cpp = cpp_file#write in let strq = strq ctx.ctx_common in - if tcpp_interface.if_debug_level > 1 then - print_endline - ("Found interface definition:" ^ join_class_path tcpp_interface.if_class.cl_path "::"); - cpp_file#write_h "#include \n\n"; let all_referenced = From 4f12a08520d181266f503413535eec0ea07706a4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 12 Nov 2024 11:11:51 +0000 Subject: [PATCH 73/97] add space after static --- src/generators/cpp/gen/cppGenClassHeader.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 8ff96ef5a51..7c0dd675d33 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -49,7 +49,7 @@ let gen_member_function ctx class_def is_static func = 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 - let prefix = (if is_static then "static" else "") in + let prefix = (if is_static then "static " else "") in (* let remap_name = native_field_name_remap is_static field in *) Printf.sprintf "\t\t%s %s %s(%s);\n" prefix return_type_str func.tcf_name (print_arg_list func.tcf_func.tf_args "") |> output; From 583404965dcc8883b11007ec04703b3a0305c3f7 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 12 Nov 2024 11:12:10 +0000 Subject: [PATCH 74/97] remove unused variable --- src/generators/cpp/gen/cppGenClassImplementation.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index fe79093614f..284aba1ca22 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -15,7 +15,6 @@ 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 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 needsWrapper t = From 151c563af6f8a0671fba6103678b25a88b4a7dbd Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 12 Nov 2024 17:00:53 +0000 Subject: [PATCH 75/97] ensure SourceFile paths are made absolute --- src/generators/gencpp.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 33e816d37d5..1a48db6cd4f 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -289,7 +289,7 @@ let generate_source ctx = 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 -> source :: acc.extern_src + | 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 } From 2787b94206bfff79c99ba8f77841fbb82efe4b1c Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sat, 16 Nov 2024 21:04:53 +0000 Subject: [PATCH 76/97] some debugging --- bodge/dump/cpp/haxe/EnumTools.dump | 237 ++++++++++++++++++ src/generators/cpp/cppRetyper.ml | 14 +- src/generators/cpp/gen/cppGen.ml | 21 -- .../cpp/gen/cppGenClassImplementation.ml | 20 +- 4 files changed, 269 insertions(+), 23 deletions(-) create mode 100644 bodge/dump/cpp/haxe/EnumTools.dump diff --git a/bodge/dump/cpp/haxe/EnumTools.dump b/bodge/dump/cpp/haxe/EnumTools.dump new file mode 100644 index 00000000000..bbaf967485b --- /dev/null +++ b/bodge/dump/cpp/haxe/EnumTools.dump @@ -0,0 +1,237 @@ +{ + cl_path = haxe.EnumTools; + cl_module = haxe.EnumTools; + cl_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1440-4101; + cl_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1446-1455; + cl_private = false; + cl_doc = + This class provides advanced methods on enums. It is ideally used with + `using EnumTools` and then acts as an + [extension](https://haxe.org/manual/lf-static-extension.html) to the + `enum` types. + + If the first argument to any of the methods is `null`, the result is + unspecified. +; + cl_meta = []; + cl_params = []; + cl_kind = KNormal; + cl_super = None; + cl_implements = []; + cl_array_access = None; + cl_init = None; + cl_constructor = None; + cl_ordered_fields = []; + cl_ordered_statics = [{ + cf_name = getName; + cf_doc = + Returns the name of enum `e`, including its path. + + If `e` is inside a package, the package structure is returned dot- + separated, with another dot separating the enum name: + + pack1.pack2.(...).packN.EnumName + + If `e` is a sub-type of a Haxe module, that module is not part of the + package structure. + + If `e` has no package, the enum name is returned. + + If `e` is `null`, the result is unspecified. + + The enum name does not include any type parameters. + ; + cf_type = TFun([e:TAbstract(Enum, [TInst(getName.T, [])])], TInst(String, [])); + cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1934-2020; + cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1957-1964; + cf_meta = []; + cf_kind = inline method; + cf_params = [{ + name = T; + class = getName.T; + host = TPHMethod; + type = TInst(getName.T, []); + constraints = []; + default = None; + }]; + cf_expr = [Function:(e : Enum) -> String] + [Arg e<42>(VUsedByTyper):Enum] + [Block:Dynamic] + [Return:Dynamic] + [Call:String] + [Field:(e : Enum) -> String] + [TypeExpr Type:Class] + [FStatic:(e : Enum) -> String] + Type + getEnumName:(e : Enum) -> String + [Local e(42):Enum:Enum]; + cf_flags = CfPostProcessed CfStatic CfPublic; + cf_overloads = []; + } + { + cf_name = createByName; + cf_doc = + Creates an instance of enum `e` by calling its constructor `constr` with + arguments `params`. + + If `e` or `constr` is `null`, or if enum `e` has no constructor named + `constr`, or if the number of elements in `params` does not match the + expected number of constructor arguments, or if any argument has an + invalid type, the result is unspecified. + ; + cf_type = TFun([e:TAbstract(Enum, [TInst(createByName.T, [])]), constr:TInst(String, []), ?params:TAbstract(Null, [TInst(Array, [TDynamic])])], TInst(createByName.T, [])); + cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 2388-2528; + cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 2411-2423; + cf_meta = []; + cf_kind = inline method; + cf_params = [{ + name = T; + class = createByName.T; + host = TPHMethod; + type = TInst(createByName.T, []); + constraints = []; + default = None; + }]; + cf_expr = [Function:(e : Enum, constr : String, ?params : Null>) -> createByName.T] + [Arg e<118>(VUsedByTyper):Enum] + [Arg constr<119>(VUsedByTyper):String] + [Arg params<120>(VUsedByTyper):Null>] [Const:Null>] null + [Block:Dynamic] + [Return:Dynamic] + [Call:createByName.T] + [Field:(e : Enum, constr : String, ?params : Null>) -> createByName.T] + [TypeExpr Type:Class] + [FStatic:(e : Enum, constr : String, ?params : Null>) -> createByName.T] + Type + createEnum:(e : Enum, constr : String, ?params : Null>) -> createEnum.T + [Local e(118):Enum:Enum] + [Local constr(119):String:String] + [Local params(120):Null>:Null>]; + cf_flags = CfPostProcessed CfStatic CfPublic; + cf_overloads = []; + } + { + cf_name = createByIndex; + cf_doc = + Creates an instance of enum `e` by calling its constructor number + `index` with arguments `params`. + + The constructor indices are preserved from Haxe syntax, so the first + declared is index 0, the next index 1 etc. + + If `e` or `index` is `null`, or if enum `e` has no constructor + corresponding to index `index`, or if the number of elements in `params` + does not match the expected number of constructor arguments, or if any + argument has an invalid type, the result is unspecified. + ; + cf_type = TFun([e:TAbstract(Enum, [TInst(createByIndex.T, [])]), index:TAbstract(Int, []), ?params:TAbstract(Null, [TInst(Array, [TDynamic])])], TInst(createByIndex.T, [])); + cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3034-3175; + cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3057-3070; + cf_meta = []; + cf_kind = inline method; + cf_params = [{ + name = T; + class = createByIndex.T; + host = TPHMethod; + type = TInst(createByIndex.T, []); + constraints = []; + default = None; + }]; + cf_expr = [Function:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] + [Arg e<121>(VUsedByTyper):Enum] + [Arg index<122>(VUsedByTyper):Int] + [Arg params<123>(VUsedByTyper):Null>] [Const:Null>] null + [Block:Dynamic] + [Return:Dynamic] + [Call:createByIndex.T] + [Field:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] + [TypeExpr Type:Class] + [FStatic:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] + Type + createEnumIndex:(e : Enum, index : Int, ?params : Null>) -> createEnumIndex.T + [Local e(121):Enum:Enum] + [Local index(122):Int:Int] + [Local params(123):Null>:Null>]; + cf_flags = CfPostProcessed CfStatic CfPublic; + cf_overloads = []; + } + { + cf_name = createAll; + cf_doc = + Returns a list of all constructors of enum `e` that require no + arguments. + + This may return the empty Array `[]` if all constructors of `e` require + arguments. + + Otherwise an instance of `e` constructed through each of its non- + argument constructors is returned, in the order of the constructor + declaration. + + If `e` is `null`, the result is unspecified. + ; + cf_type = TFun([e:TAbstract(Enum, [TInst(createAll.T, [])])], TInst(Array, [TInst(createAll.T, [])])); + cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3555-3642; + cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3578-3587; + cf_meta = []; + cf_kind = inline method; + cf_params = [{ + name = T; + class = createAll.T; + host = TPHMethod; + type = TInst(createAll.T, []); + constraints = []; + default = None; + }]; + cf_expr = [Function:(e : Enum) -> Array] + [Arg e<124>(VUsedByTyper):Enum] + [Block:Dynamic] + [Return:Dynamic] + [Call:Array] + [Field:(e : Enum) -> Array] + [TypeExpr Type:Class] + [FStatic:(e : Enum) -> Array] + Type + allEnums:(e : Enum) -> Array + [Local e(124):Enum:Enum]; + cf_flags = CfPostProcessed CfStatic CfPublic; + cf_overloads = []; + } + { + cf_name = getConstructors; + cf_doc = + Returns a list of the names of all constructors of enum `e`. + + The order of the constructor names in the returned Array is preserved + from the original syntax. + + If `c` is `null`, the result is unspecified. + ; + cf_type = TFun([e:TAbstract(Enum, [TInst(getConstructors.T, [])])], TInst(Array, [TInst(String, [])])); + cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3867-3974; + cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3890-3905; + cf_meta = []; + cf_kind = inline method; + cf_params = [{ + name = T; + class = getConstructors.T; + host = TPHMethod; + type = TInst(getConstructors.T, []); + constraints = []; + default = None; + }]; + cf_expr = [Function:(e : Enum) -> Array] + [Arg e<125>(VUsedByTyper):Enum] + [Block:Dynamic] + [Return:Dynamic] + [Call:Array] + [Field:(e : Enum) -> Array] + [TypeExpr Type:Class] + [FStatic:(e : Enum) -> Array] + Type + getEnumConstructs:(e : Enum) -> Array + [Local e(125):Enum:Enum]; + cf_flags = CfPostProcessed CfStatic CfPublic; + cf_overloads = []; + }]; +} \ No newline at end of file diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 055ca8beddd..ddf3ff6a637 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1462,6 +1462,18 @@ let native_field_name_remap field = | None -> keyword_remap field.cf_name +let has_new_gc_references class_def = + let type_cant_be_null haxe_type = + match cpp_type_of haxe_type with TCppScalar _ -> true | _ -> false + in + + let is_gc_reference field = + should_implement_field field + && is_data_member field + && not (type_cant_be_null field.cf_type) + in + List.exists is_gc_reference class_def.cl_ordered_fields + let rec tcpp_class_from_tclass ctx ids slots class_def = let scriptable = Common.defined ctx.ctx_common Define.Scriptable in @@ -1646,7 +1658,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = 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 List.exists (fun v -> not (cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container else f) + |> (fun f -> if has_new_gc_references class_def then set_tcpp_class_flag f Container 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) diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index b81a35854f5..276217a97e0 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -80,27 +80,6 @@ let print_tfun_arg_list include_names arg_list = |> List.map (fun (name, o, arg_type) -> (oType o arg_type) ^ (if include_names then " " ^ keyword_remap name else "")) |> String.concat "," -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) - 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 -> - Some (tcpp_to_string_suffix "_obj" (cpp_instance_type klass params)) - | Some (klass, _) -> find_next_super_iteration klass - | _ -> None - let cpp_member_name_of member = match get_meta_string member.cf_meta Meta.Native with | Some n -> n diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 284aba1ca22..b6551d8bee6 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -509,12 +509,26 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_dynamic_functions; output_cpp "}\n\n"; + Printf.printf "%s (container : %b)\n" tcpp_class.tcl_name (has_tcpp_class_flag tcpp_class Container); + if has_tcpp_class_flag tcpp_class Container then ( - let super_needs_iteration = find_next_super_iteration class_def in + let rec find_next_super_iteration cls = + match cls.tcl_super with + | Some super when has_tcpp_class_flag super Container -> + Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class [])) + | Some super -> + find_next_super_iteration super + | None -> + None + in + + 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 + + Printf.printf "\tncontainer parent : %s\n" (super_needs_iteration |> Option.default "none"); (* MARK function - explicitly mark all child pointers *) output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n"); @@ -799,11 +813,15 @@ let generate_managed_class base_ctx tcpp_class = | None -> Printf.sprintf "static ::String* %s_sMemberFields = 0;\n\n" class_name |> output_cpp); + Printf.printf "\tgc statics (%i)\n" (List.length tcpp_class.tcl_static_variables); + 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 + List.iter (fun v -> Printf.printf "\t- %s\n" v.tcv_name) tcpp_class.tcl_static_variables; + (* Mark static variables as used *) let marks = tcpp_class.tcl_static_variables From 63eb0066f1132fbcfe8256d57b94d8e3d6a294ec Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 17 Nov 2024 12:48:05 +0000 Subject: [PATCH 77/97] remove debugging prints and store class params --- src/generators/cpp/cppAst.ml | 1 + src/generators/cpp/cppRetyper.ml | 7 ++++--- src/generators/cpp/gen/cppGenClassHeader.ml | 17 +++++------------ .../cpp/gen/cppGenClassImplementation.ml | 10 +--------- src/generators/gencpp.ml | 2 +- 5 files changed, 12 insertions(+), 25 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 7df9b43056a..9346e93ee86 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -233,6 +233,7 @@ and tcpp_class_variable = { and tcpp_class = { tcl_class : tclass; + tcl_params : tparams; tcl_name : string; tcl_id : int32; tcl_flags : int; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index ddf3ff6a637..9a8b3091f43 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1474,7 +1474,7 @@ let has_new_gc_references class_def = in List.exists is_gc_reference class_def.cl_ordered_fields -let rec tcpp_class_from_tclass ctx ids slots class_def = +let rec tcpp_class_from_tclass ctx ids slots class_def class_params = let scriptable = Common.defined ctx.ctx_common Define.Scriptable in let create_function field func = { @@ -1643,8 +1643,8 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let (slots, ids, parent) = match class_def.cl_super with - | Some (cls, _) -> - let slots, ids, parent = tcpp_class_from_tclass ctx ids slots cls in + | 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) @@ -1673,6 +1673,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def = let cls = { tcl_class = class_def; + tcl_params = class_params; tcl_id = id; tcl_name = class_name class_def; tcl_flags = flags; diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 7c0dd675d33..ee2979ce07d 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -198,7 +198,6 @@ let generate_managed_header base_ctx tcpp_class = 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 isContainer = if has_tcpp_class_flag tcpp_class Container then "true" else "false" in let constructor_type_args = tcpp_class.tcl_class @@ -211,11 +210,9 @@ let generate_managed_header base_ctx tcpp_class = let strq = strq ctx.ctx_common 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 + 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 @@ -233,15 +230,11 @@ let generate_managed_header base_ctx tcpp_class = output_h "\n\tpublic:\n"; output_h ("\t\tenum { _hx_ClassId = " ^ classIdTxt ^ " };\n\n"); output_h ("\t\tvoid __construct(" ^ constructor_type_args ^ ");\n"); - output_h - ("\t\tinline void *operator new(size_t inSize, bool inContainer=" - ^ isContainer ^ ",const char *inName=" ^ gcName ^ ")\n"); + Printf.sprintf "\t\tinline void *operator new(size_t inSize, bool inContainer=%b, const char* inName=%s)\n" (has_tcpp_class_flag tcpp_class 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"; - output_h - ("\t\t\t{ return ::hx::Object::operator new(inSize+extra," ^ isContainer - ^ "," ^ gcName ^ "); }\n"); + Printf.sprintf "\t\t\t{ return ::hx::Object::operator new(inSize + extra, %b, %s); }\n" (has_tcpp_class_flag tcpp_class Container) gcName |> output_h; if has_class_flag class_def CAbstract then output_h "\n" else if can_inline_constructor base_ctx class_def diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index b6551d8bee6..203f31efdc8 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -509,13 +509,11 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_dynamic_functions; output_cpp "}\n\n"; - Printf.printf "%s (container : %b)\n" tcpp_class.tcl_name (has_tcpp_class_flag tcpp_class Container); - if has_tcpp_class_flag tcpp_class Container then ( let rec find_next_super_iteration cls = match cls.tcl_super with | Some super when has_tcpp_class_flag super Container -> - Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class [])) + Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params)) | Some super -> find_next_super_iteration super | None -> @@ -528,8 +526,6 @@ let generate_managed_class base_ctx tcpp_class = Printf.sprintf "\t%s(%s, \"%s\");\n" macro var.tcv_name var.tcv_field.cf_name |> output_cpp in - Printf.printf "\tncontainer parent : %s\n" (super_needs_iteration |> Option.default "none"); - (* 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"); @@ -813,15 +809,11 @@ let generate_managed_class base_ctx tcpp_class = | None -> Printf.sprintf "static ::String* %s_sMemberFields = 0;\n\n" class_name |> output_cpp); - Printf.printf "\tgc statics (%i)\n" (List.length tcpp_class.tcl_static_variables); - 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 - List.iter (fun v -> Printf.printf "\t- %s\n" v.tcv_name) tcpp_class.tcl_static_variables; - (* Mark static variables as used *) let marks = tcpp_class.tcl_static_variables diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 1a48db6cd4f..069339f1573 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -305,7 +305,7 @@ let generate_source ctx = 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 + 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 From ba5a2289572b277e3ac1998e5608b78f04d5a9af Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 17 Nov 2024 14:07:01 +0000 Subject: [PATCH 78/97] don't use already mangled name when generating the getter name in reflection --- src/generators/cpp/gen/cppGenClassImplementation.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 203f31efdc8..32cf0ea060f 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -590,7 +590,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 | _ -> From c57a4e50ed9acfe5a1dc692ec40cab667dc43240 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Sun, 17 Nov 2024 14:14:08 +0000 Subject: [PATCH 79/97] same for setters --- src/generators/cpp/gen/cppGenClassImplementation.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 32cf0ea060f..1337dfc4829 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -612,7 +612,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 @@ -675,7 +675,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 @@ -694,7 +694,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 @@ -721,7 +721,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 @@ -738,7 +738,7 @@ let generate_managed_class base_ctx tcpp_class = 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_name |> get_wrapper 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 (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 From e3f92b3c539a2ad2d053cc445cabe1a72ae58241 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 18 Nov 2024 17:36:53 +0000 Subject: [PATCH 80/97] dont use new gc references function --- src/generators/cpp/cppRetyper.ml | 14 +------------- src/generators/gencpp.ml | 6 ++++-- 2 files changed, 5 insertions(+), 15 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 9a8b3091f43..323f3e6c45c 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1462,18 +1462,6 @@ let native_field_name_remap field = | None -> keyword_remap field.cf_name -let has_new_gc_references class_def = - let type_cant_be_null haxe_type = - match cpp_type_of haxe_type with TCppScalar _ -> true | _ -> false - in - - let is_gc_reference field = - should_implement_field field - && is_data_member field - && not (type_cant_be_null field.cf_type) - in - List.exists is_gc_reference class_def.cl_ordered_fields - let rec tcpp_class_from_tclass ctx ids slots class_def class_params = let scriptable = Common.defined ctx.ctx_common Define.Scriptable in @@ -1658,7 +1646,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = 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_new_gc_references class_def then set_tcpp_class_flag f Container else f) + |> (fun f -> if List.exists (fun v -> not (cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container 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) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 069339f1573..f0e2eed2c2a 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -177,7 +177,7 @@ let write_build_options common_ctx filename defines = writer#close let create_member_types common_ctx = - List.fold_left (fun acc object_def -> + 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 = @@ -189,7 +189,9 @@ let create_member_types common_ctx = | _ -> acc in (match class_def.cl_super with Some (super, _) -> add_override acc super | _ -> acc) - | _ -> acc) StringMap.empty common_ctx.types + | _ -> 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 = From c1b73326871eac74660897cb203efc3a1c8f691a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 18 Nov 2024 17:37:28 +0000 Subject: [PATCH 81/97] better handling of static and virtual attributes --- src/generators/cpp/gen/cppGenClassHeader.ml | 45 +++++++++++++-------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index ee2979ce07d..25ca968d8bf 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -37,24 +37,35 @@ let gen_dynamic_function ctx class_def is_static func = let gen_member_function ctx class_def is_static func = let output = ctx.ctx_output in - - if func.tcf_is_virtual && not is_static then ( - if not func.tcf_is_scriptable && not func.tcf_is_external 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 -> output v - | None -> () + + 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 - output "virtual "); + acc + in + + let attributes = [] + |> fold_static + |> fold_virtual + |> String.concat " " + 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 - let prefix = (if is_static then "static " else "") in - (* let remap_name = native_field_name_remap is_static field in *) - Printf.sprintf "\t\t%s %s %s(%s);\n" prefix return_type_str func.tcf_name (print_arg_list func.tcf_func.tf_args "") |> output; + 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; if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then - Printf.sprintf "%s::Dynamic %s_dyn();\n" prefix func.tcf_name |> output + 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 @@ -161,14 +172,17 @@ let generate_native_header base_ctx tcpp_class = 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_static_variables - |> List.iter (gen_member_variable 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); @@ -176,9 +190,6 @@ let generate_native_header base_ctx tcpp_class = tcpp_class.tcl_dynamic_functions |> List.iter (gen_dynamic_function ctx class_def false); - tcpp_class.tcl_variables - |> List.iter (gen_member_variable ctx class_def false); - output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; From f56c0d493634aaec5707d89432447dc98b6d9dde Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Mon, 18 Nov 2024 19:20:27 +0000 Subject: [PATCH 82/97] generate scriptable class using tcpp class function lists --- src/generators/cpp/cppTypeUtils.ml | 34 ----- .../cpp/gen/cppGenClassImplementation.ml | 138 +++++++++++------- src/generators/cpp/gen/cppReferences.ml | 30 ++++ 3 files changed, 114 insertions(+), 88 deletions(-) diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index 8d70bbc9bff..0b0387c9728 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -319,40 +319,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 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 |> List.rev - 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/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 1337dfc4829..0943fd6dc65 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -203,27 +203,27 @@ let gen_dynamic_function_allocator ctx output_cpp tcpp_class = 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 strq = strq ctx_common in - - let filter_vars var = + let filter_vars var acc = if var.tcv_is_reflective then - Some (Printf.sprintf "\t%s" (strq var.tcv_field.cf_name)) + Printf.sprintf "\t%s" (strq ctx_common var.tcv_field.cf_name) :: acc else - None in - let filter_funcs func = + acc in + let filter_funcs func acc = if func.tcf_is_reflective then - Some (Printf.sprintf "\t%s" (strq func.tcf_field.cf_name)) + Printf.sprintf "\t%s" (strq ctx_common func.tcf_field.cf_name) :: acc else - None in + acc in - let reflective_variables = variables |> List.filter_map filter_vars in - let reflective_functions = functions |> List.filter_map filter_funcs in + let calls = + [ "\t::String(null())" ] + |> List.fold_right filter_vars variables + |> List.fold_right filter_funcs functions + in - match reflective_variables @ reflective_functions with - | [] -> + if List.length calls > 1 then + Some (String.concat ",\n" calls) + else None - | concat -> - Some (concat @ [ "\t::String(null())" ] |> String.concat ",\n") let cpp_interface_impl_name cls = "_hx_" ^ join_class_path cls.cl_path "_" @@ -839,7 +839,7 @@ let generate_managed_class base_ctx tcpp_class = 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" @@ -861,7 +861,7 @@ let generate_managed_class base_ctx tcpp_class = (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 ^ ")" )) @@ -886,44 +886,42 @@ let generate_managed_class base_ctx tcpp_class = in if scriptable then ( - 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 - - output_cpp ("\t" ^ return_type ^ " " ^ name ^ "( " ^ args ^ " ) {\n"); - output_cpp ("\tif (" ^ vtable ^ ") {\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 ^ "(" - ^ keyword_remap name ^ ");\n")) + 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( this );\n"); + + List.iter + (fun (name, opt, t) -> + 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"); - output_cpp ("\t} else " ^ ret); - output_cpp - (class_name ^ "::" ^ name ^ "(" ^ String.concat "," names ^ ");"); - if return_type <> "void" then output_cpp "return null();"; - output_cpp "}\n"; - in + output_cpp + ("\t\t" ^ ret ^ "__ctx->run" ^ CppCppia.script_type func.tcf_func.tf_type false ^ "(" ^ vtable ^ ");\n"); + output_cpp ("\t} else " ^ ret); + + let names = List.map (fun (n, _, _) -> keyword_remap n) f_args in + + output_cpp + (class_name ^ "::" ^ func.tcf_name ^ "(" ^ String.concat "," names ^ ");"); - let sctipt_name = class_name ^ "__scriptable" in + if return_type <> "void" then output_cpp "return null();"; - output_cpp ("class " ^ sctipt_name ^ " : public " ^ class_name ^ " {\n"); - output_cpp (" typedef " ^ sctipt_name ^ " __ME;\n"); - output_cpp (" typedef " ^ class_name ^ " super;\n"); + output_cpp "}\n"; + | _ -> + abort "expected function type to be tfun" func.tcf_field.cf_pos + in + + let script_name = class_name ^ "__scriptable" in let has_funky_toString = List.exists (fun func -> func.tcf_name = "toString") @@ -936,14 +934,46 @@ let generate_managed_class base_ctx tcpp_class = if has_funky_toString then class_name ^ "::super" else class_name 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"; - class_def - |> all_virtual_functions - |> List.filter (fun (field, _, _) -> field.cf_name <> "toString") - |> ExtList.List.iteri dump_script_field; + (* + 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 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 + + flatten_tcpp_class_functions + |> List.filter (fun f -> f.tcf_name <> "toString") + |> ExtList.List.iteri dump_script_func; output_cpp "};\n\n"; if List.length tcpp_class.tcl_functions > 0 || List.length tcpp_class.tcl_static_functions > 0 then ( diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index cb816b05f77..beb4d1f737a 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -16,6 +16,36 @@ open CppContext or for building the dependencies in the Build.xml file *) 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 = From 4bf6e1c3a626f5f8dfa52faf21997200a6befa0a Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 19 Nov 2024 13:45:56 +0000 Subject: [PATCH 83/97] go back to type cant be null --- src/generators/cpp/cppRetyper.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 323f3e6c45c..01835f603aa 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1643,10 +1643,13 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) |> values in + let type_cant_be_null haxe_type = + match cpp_type_of haxe_type with TCppScalar _ -> true | _ -> false 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 List.exists (fun v -> not (cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container else f) + |> (fun f -> if List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container 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) From 08bce304888824407cf1aaff2893f742c1d238f4 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 19 Nov 2024 21:23:22 +0000 Subject: [PATCH 84/97] Container flag refers to entire inheritance tree --- src/generators/cpp/cppRetyper.ml | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 01835f603aa..534f0617b4b 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1643,13 +1643,24 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) |> values in - let type_cant_be_null haxe_type = - match cpp_type_of haxe_type with TCppScalar _ -> true | _ -> false in + let is_gc_container = + let type_cant_be_null t = + match cpp_type_of t with TCppScalar _ -> true | _ -> false in + + let rec gc_container variables super = + match List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables, super with + | true, _ -> true + | false, Some super -> gc_container super.tcl_variables super.tcl_super + | false, None -> false + in + + gc_container variables parent + 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 List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables then set_tcpp_class_flag f Container else f) + |> (fun f -> if is_gc_container then set_tcpp_class_flag f Container 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) From 1da4f139f01b0a40de1a1cff64482d97ab9d6ec7 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 19 Nov 2024 21:39:09 +0000 Subject: [PATCH 85/97] allow code to easily distinguish between the different container types --- src/generators/cpp/cppAst.ml | 6 +++++- src/generators/cpp/cppRetyper.ml | 14 +++++++------- src/generators/cpp/gen/cppGen.ml | 8 +++----- src/generators/cpp/gen/cppGenClassHeader.ml | 6 +++--- .../cpp/gen/cppGenClassImplementation.ml | 4 ++-- 5 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 9346e93ee86..7d71a4757f5 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -196,9 +196,12 @@ and tcpp_expr_expr = | 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 - | Container | Scriptable | MemberGet | MemberSet @@ -239,6 +242,7 @@ and tcpp_class = { 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; diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 534f0617b4b..f702cf4ceab 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1643,24 +1643,23 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = |> List.fold_left folder (slots, PathMap.empty, PathMap.empty) |> values in - let is_gc_container = + 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 = + let rec gc_container variables super v = match List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables, super with - | true, _ -> true - | false, Some super -> gc_container super.tcl_variables super.tcl_super - | false, None -> false + | true, _ -> Some v + | false, Some super -> gc_container super.tcl_variables super.tcl_super Parent + | false, None -> None in - gc_container variables parent + 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 is_gc_container then set_tcpp_class_flag f Container 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) @@ -1680,6 +1679,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = 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 || Common.defined ctx.ctx_common Define.NoDebug then 0 else ctx.ctx_debug_level; tcl_static_variables = static_variables; tcl_static_properties = static_properties; diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 276217a97e0..18abf75f267 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1779,7 +1779,6 @@ let generate_constructor ctx out tcpp_class isHeader = 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 isContainer = if has_tcpp_class_flag tcpp_class Container then "true" else "false" in let cargs = constructor_arg_var_list tcpp_class.tcl_class in let constructor_type_args = String.concat "," @@ -1803,10 +1802,9 @@ let generate_constructor ctx out tcpp_class 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 diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index 25ca968d8bf..e56779f0773 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -241,11 +241,11 @@ let generate_managed_header base_ctx tcpp_class = 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" (has_tcpp_class_flag tcpp_class Container) gcName |> output_h; + 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" (has_tcpp_class_flag tcpp_class Container) gcName |> output_h; + 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 @@ -296,7 +296,7 @@ let generate_managed_header base_ctx tcpp_class = ^ " *>(this)->__compare(Dynamic((::hx::Object *)inRHS)); }\n"); output_h "\t\tstatic void __register();\n"; - if has_tcpp_class_flag tcpp_class Container then ( + 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"); diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index 0943fd6dc65..8647e332509 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -509,10 +509,10 @@ let generate_managed_class base_ctx tcpp_class = tcpp_class.tcl_dynamic_functions; output_cpp "}\n\n"; - if has_tcpp_class_flag tcpp_class Container then ( + if tcpp_class.tcl_container = Some Current then ( let rec find_next_super_iteration cls = match cls.tcl_super with - | Some super when has_tcpp_class_flag super Container -> + | 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 From 078a5a891c0b349253d4688ddf7bbe932393cf04 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Tue, 19 Nov 2024 21:41:20 +0000 Subject: [PATCH 86/97] remove accidentally tracked file --- bodge/dump/cpp/haxe/EnumTools.dump | 237 ----------------------------- 1 file changed, 237 deletions(-) delete mode 100644 bodge/dump/cpp/haxe/EnumTools.dump diff --git a/bodge/dump/cpp/haxe/EnumTools.dump b/bodge/dump/cpp/haxe/EnumTools.dump deleted file mode 100644 index bbaf967485b..00000000000 --- a/bodge/dump/cpp/haxe/EnumTools.dump +++ /dev/null @@ -1,237 +0,0 @@ -{ - cl_path = haxe.EnumTools; - cl_module = haxe.EnumTools; - cl_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1440-4101; - cl_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1446-1455; - cl_private = false; - cl_doc = - This class provides advanced methods on enums. It is ideally used with - `using EnumTools` and then acts as an - [extension](https://haxe.org/manual/lf-static-extension.html) to the - `enum` types. - - If the first argument to any of the methods is `null`, the result is - unspecified. -; - cl_meta = []; - cl_params = []; - cl_kind = KNormal; - cl_super = None; - cl_implements = []; - cl_array_access = None; - cl_init = None; - cl_constructor = None; - cl_ordered_fields = []; - cl_ordered_statics = [{ - cf_name = getName; - cf_doc = - Returns the name of enum `e`, including its path. - - If `e` is inside a package, the package structure is returned dot- - separated, with another dot separating the enum name: - - pack1.pack2.(...).packN.EnumName - - If `e` is a sub-type of a Haxe module, that module is not part of the - package structure. - - If `e` has no package, the enum name is returned. - - If `e` is `null`, the result is unspecified. - - The enum name does not include any type parameters. - ; - cf_type = TFun([e:TAbstract(Enum, [TInst(getName.T, [])])], TInst(String, [])); - cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1934-2020; - cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 1957-1964; - cf_meta = []; - cf_kind = inline method; - cf_params = [{ - name = T; - class = getName.T; - host = TPHMethod; - type = TInst(getName.T, []); - constraints = []; - default = None; - }]; - cf_expr = [Function:(e : Enum) -> String] - [Arg e<42>(VUsedByTyper):Enum] - [Block:Dynamic] - [Return:Dynamic] - [Call:String] - [Field:(e : Enum) -> String] - [TypeExpr Type:Class] - [FStatic:(e : Enum) -> String] - Type - getEnumName:(e : Enum) -> String - [Local e(42):Enum:Enum]; - cf_flags = CfPostProcessed CfStatic CfPublic; - cf_overloads = []; - } - { - cf_name = createByName; - cf_doc = - Creates an instance of enum `e` by calling its constructor `constr` with - arguments `params`. - - If `e` or `constr` is `null`, or if enum `e` has no constructor named - `constr`, or if the number of elements in `params` does not match the - expected number of constructor arguments, or if any argument has an - invalid type, the result is unspecified. - ; - cf_type = TFun([e:TAbstract(Enum, [TInst(createByName.T, [])]), constr:TInst(String, []), ?params:TAbstract(Null, [TInst(Array, [TDynamic])])], TInst(createByName.T, [])); - cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 2388-2528; - cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 2411-2423; - cf_meta = []; - cf_kind = inline method; - cf_params = [{ - name = T; - class = createByName.T; - host = TPHMethod; - type = TInst(createByName.T, []); - constraints = []; - default = None; - }]; - cf_expr = [Function:(e : Enum, constr : String, ?params : Null>) -> createByName.T] - [Arg e<118>(VUsedByTyper):Enum] - [Arg constr<119>(VUsedByTyper):String] - [Arg params<120>(VUsedByTyper):Null>] [Const:Null>] null - [Block:Dynamic] - [Return:Dynamic] - [Call:createByName.T] - [Field:(e : Enum, constr : String, ?params : Null>) -> createByName.T] - [TypeExpr Type:Class] - [FStatic:(e : Enum, constr : String, ?params : Null>) -> createByName.T] - Type - createEnum:(e : Enum, constr : String, ?params : Null>) -> createEnum.T - [Local e(118):Enum:Enum] - [Local constr(119):String:String] - [Local params(120):Null>:Null>]; - cf_flags = CfPostProcessed CfStatic CfPublic; - cf_overloads = []; - } - { - cf_name = createByIndex; - cf_doc = - Creates an instance of enum `e` by calling its constructor number - `index` with arguments `params`. - - The constructor indices are preserved from Haxe syntax, so the first - declared is index 0, the next index 1 etc. - - If `e` or `index` is `null`, or if enum `e` has no constructor - corresponding to index `index`, or if the number of elements in `params` - does not match the expected number of constructor arguments, or if any - argument has an invalid type, the result is unspecified. - ; - cf_type = TFun([e:TAbstract(Enum, [TInst(createByIndex.T, [])]), index:TAbstract(Int, []), ?params:TAbstract(Null, [TInst(Array, [TDynamic])])], TInst(createByIndex.T, [])); - cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3034-3175; - cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3057-3070; - cf_meta = []; - cf_kind = inline method; - cf_params = [{ - name = T; - class = createByIndex.T; - host = TPHMethod; - type = TInst(createByIndex.T, []); - constraints = []; - default = None; - }]; - cf_expr = [Function:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] - [Arg e<121>(VUsedByTyper):Enum] - [Arg index<122>(VUsedByTyper):Int] - [Arg params<123>(VUsedByTyper):Null>] [Const:Null>] null - [Block:Dynamic] - [Return:Dynamic] - [Call:createByIndex.T] - [Field:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] - [TypeExpr Type:Class] - [FStatic:(e : Enum, index : Int, ?params : Null>) -> createByIndex.T] - Type - createEnumIndex:(e : Enum, index : Int, ?params : Null>) -> createEnumIndex.T - [Local e(121):Enum:Enum] - [Local index(122):Int:Int] - [Local params(123):Null>:Null>]; - cf_flags = CfPostProcessed CfStatic CfPublic; - cf_overloads = []; - } - { - cf_name = createAll; - cf_doc = - Returns a list of all constructors of enum `e` that require no - arguments. - - This may return the empty Array `[]` if all constructors of `e` require - arguments. - - Otherwise an instance of `e` constructed through each of its non- - argument constructors is returned, in the order of the constructor - declaration. - - If `e` is `null`, the result is unspecified. - ; - cf_type = TFun([e:TAbstract(Enum, [TInst(createAll.T, [])])], TInst(Array, [TInst(createAll.T, [])])); - cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3555-3642; - cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3578-3587; - cf_meta = []; - cf_kind = inline method; - cf_params = [{ - name = T; - class = createAll.T; - host = TPHMethod; - type = TInst(createAll.T, []); - constraints = []; - default = None; - }]; - cf_expr = [Function:(e : Enum) -> Array] - [Arg e<124>(VUsedByTyper):Enum] - [Block:Dynamic] - [Return:Dynamic] - [Call:Array] - [Field:(e : Enum) -> Array] - [TypeExpr Type:Class] - [FStatic:(e : Enum) -> Array] - Type - allEnums:(e : Enum) -> Array - [Local e(124):Enum:Enum]; - cf_flags = CfPostProcessed CfStatic CfPublic; - cf_overloads = []; - } - { - cf_name = getConstructors; - cf_doc = - Returns a list of the names of all constructors of enum `e`. - - The order of the constructor names in the returned Array is preserved - from the original syntax. - - If `c` is `null`, the result is unspecified. - ; - cf_type = TFun([e:TAbstract(Enum, [TInst(getConstructors.T, [])])], TInst(Array, [TInst(String, [])])); - cf_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3867-3974; - cf_name_pos = /usr/local/share/haxe/std/haxe/EnumTools.hx: 3890-3905; - cf_meta = []; - cf_kind = inline method; - cf_params = [{ - name = T; - class = getConstructors.T; - host = TPHMethod; - type = TInst(getConstructors.T, []); - constraints = []; - default = None; - }]; - cf_expr = [Function:(e : Enum) -> Array] - [Arg e<125>(VUsedByTyper):Enum] - [Block:Dynamic] - [Return:Dynamic] - [Call:Array] - [Field:(e : Enum) -> Array] - [TypeExpr Type:Class] - [FStatic:(e : Enum) -> Array] - Type - getEnumConstructs:(e : Enum) -> Array - [Local e(125):Enum:Enum]; - cf_flags = CfPostProcessed CfStatic CfPublic; - cf_overloads = []; - }]; -} \ No newline at end of file From 760989cbf5c5ad49a69c14831d9a6c0ccb62ea25 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 16:50:26 +0000 Subject: [PATCH 87/97] pass a context object around the retyper --- src/generators/cpp/cppRetyper.ml | 1321 +++++++++++++++--------------- 1 file changed, 675 insertions(+), 646 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 30cbf64c569..d602aabf0bf 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -214,15 +214,15 @@ let expression ctx request_type function_args function_type expression_tree forI (* Helper functions *) - let cpp_const_type cval = + let cpp_const_type retyped_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 -> (retyped_ctx, CppInt i, TCppScalar "int") + | TBool b -> (retyped_ctx, CppBool b, TCppScalar "bool") + | TFloat f -> (retyped_ctx, CppFloat (Texpr.replace_separators f ""), TCppScalar "Float") + | TString s -> (retyped_ctx, CppString s, TCppString) | _ -> (* TNull, TThis & TSuper should already be handled *) - (CppNull, TCppNull) + (retyped_ctx, CppNull, TCppNull) in let cpp_return_type haxe_type = @@ -365,623 +365,616 @@ let expression ctx request_type function_args function_type expression_tree forI in (* Core Retyping *) - let rec retype return_type expr = + let rec retype (retyped_ctx:unit) 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 retyped_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 (retyped_ctx, []) args + |> fun (ctx, acc) -> (ctx, List.rev acc) in - let retypedExpr, retypedType = + let retyped_ctx, retypedExpr, retypedType = match expr.eexpr with | TEnumParameter (enumObj, enumField, enumIndex) -> - let retypedObj = retype TCppDynamic enumObj in - ( CppEnumParameter (retypedObj, enumField, enumIndex), + let retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic enumObj in + ( retyped_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 retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic enumObj in + (retyped_ctx, CppEnumIndex retypedObj, TCppScalar "int") | TConst TThis -> uses_this := Some !this_real; - ( CppThis !this_real, + ( retyped_ctx, + CppThis !this_real, if !this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) | TConst TSuper -> uses_this := Some !this_real; - ( CppSuper !this_real, + ( retyped_ctx, + CppSuper !this_real, if !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 -> (retyped_ctx, CppNil, TCppNull) + | TConst x -> cpp_const_type retyped_ctx x | TIdent "__global__" -> (* functions/vars will appear to be members of the virtual global object *) - (CppClassOf (([], ""), false), TCppGlobal) + (retyped_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) + (retyped_ctx, CppVar (VarLocal tvar), cpp_type_of tvar.v_type) else ( (*print_endline ("Missing tvar " ^ tvar.v_name);*) Hashtbl.replace !undeclared name tvar; 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) + (retyped_ctx, CppVar (VarClosure tvar), cpp_type_of tvar.v_type) + else + (retyped_ctx, CppExtern (name, false), cpp_type_of tvar.v_type)) + | TIdent name -> (retyped_ctx, CppExtern (name, false), return_type) | TBreak -> ( - if forCppia then (CppBreak, TCppVoid) + if forCppia then + (retyped_ctx, CppBreak, TCppVoid) else match !loop_stack with - | [] -> (CppBreak, TCppVoid) + | [] -> (retyped_ctx, CppBreak, TCppVoid) | (label_id, used) :: _ -> used := true; - (CppGoto label_id, TCppVoid)) - | TContinue -> (CppContinue, TCppVoid) - | TThrow e1 -> (CppThrow (retype TCppDynamic e1), TCppVoid) + (retyped_ctx, CppGoto label_id, TCppVoid)) + | TContinue -> (retyped_ctx, CppContinue, TCppVoid) + | TThrow e1 -> + let retyped_ctx, retyped_expr = retype retyped_ctx TCppDynamic e1 in + (retyped_ctx, CppThrow retyped_expr, TCppVoid) | TMeta ((Meta.Fixed, _, _), e) -> ( - let cppType = retype return_type e in + let retyped_ctx, cppType = retype retyped_ctx return_type e in match cppType.cppexpr with | CppObjectDecl (def, false) -> - (CppObjectDecl (def, true), cppType.cpptype) - | _ -> (cppType.cppexpr, cppType.cpptype)) + (retyped_ctx, CppObjectDecl (def, true), cppType.cpptype) + | _ -> + (retyped_ctx, cppType.cppexpr, cppType.cpptype)) | TMeta (_, e) | TParenthesis e -> - let cppType = retype return_type e in - (cppType.cppexpr, cppType.cpptype) + let retyped_ctx, cppType = retype retyped_ctx return_type e in + (retyped_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 retyped_ctx, retypedObj = retype retyped_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 + (retyped_ctx, CppNullAccess, TCppDynamic) + else if retypedObj.cpptype = TCppDynamic && not (has_class_flag clazz CInterface) then + if is_internal_member member.cf_name then + ( retyped_ctx, + CppFunction (FuncInstance (retypedObj, InstPtr, member), funcReturn), + exprType ) + else + (retyped_ctx, CppDynamicField (retypedObj, member.cf_name), TCppVariant) + else if cpp_is_struct_access retypedObj.cpptype then + match retypedObj.cppexpr with + | CppThis ThisReal -> + (retyped_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + | CppSuper this -> + ( retyped_ctx, + CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), + exprType ) + | _ -> + if is_var_field member then + ( retyped_ctx, + CppVar (VarInstance (retypedObj, member, tcpp_to_string clazzType, ".")), + exprType ) + else + ( retyped_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 -> + (retyped_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + | _ -> ( + match (retypedObj.cpptype, member.cf_name) with + (* Special variable remapping ... *) + | TCppDynamicArray, "length" when not forCppia -> + ( retyped_ctx, + CppCall (FuncInternal (retypedObj, "get_length", "->"), []), + exprType ) + | TCppInterface _, _ | TCppDynamic, _ -> + ( retyped_ctx, + CppDynamicField (retypedObj, member.cf_name), + TCppVariant ) + | TCppObjC _, _ -> + ( retyped_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 + ( retyped_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 + ( retyped_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 -> + ( retyped_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 -> + ( retyped_ctx, + CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), + exprType ) + | _ -> + ( retyped_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 + (retyped_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 + (retyped_ctx, CppVar (VarStatic (clazz, objC, member)), exprType) + else + ( retyped_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 retyped_ctx, obj = retype retyped_ctx TCppDynamic obj in + let fieldName = field.cf_name in + if obj.cpptype = TCppGlobal then + (retyped_ctx, CppExtern (fieldName, true), cpp_type_of expr.etype) + else if obj.cpptype = TCppNull then (retyped_ctx, CppNullAccess, TCppDynamic) + else if is_internal_member fieldName then + let cppType = cpp_return_type expr.etype in + if obj.cpptype = TCppString then + ( retyped_ctx, + CppFunction (FuncInternal (obj, fieldName, "."), cppType), + cppType ) + else + ( retyped_ctx, + CppFunction (FuncInternal (obj, fieldName, "->"), cppType), + cppType ) + else (retyped_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) | FDynamic fieldName -> - let obj = retype TCppDynamic obj in - if obj.cpptype = TCppNull then (CppNullAccess, TCppDynamic) + let retyped_ctx, obj = retype retyped_ctx TCppDynamic obj in + if obj.cpptype = TCppNull then (retyped_ctx, CppNullAccess, TCppDynamic) else if fieldName = "cca" && obj.cpptype = TCppString then - ( CppFunction (FuncInternal (obj, "cca", "."), TCppScalar "int"), + ( retyped_ctx, + CppFunction (FuncInternal (obj, "cca", "."), TCppScalar "int"), TCppDynamic ) else if fieldName = "__s" && obj.cpptype = TCppString then - ( CppVar (VarInternal (obj, ".", "utf8_str()")), + ( retyped_ctx, + CppVar (VarInternal (obj, ".", "utf8_str()")), TCppRawPointer ("const ", TCppScalar "char") ) else if fieldName = "__Index" then - (CppEnumIndex obj, TCppScalar "int") + (retyped_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), + ( retyped_ctx, + CppFunction (FuncInternal (obj, fieldName, "."), cppType), cppType ) else - ( CppFunction (FuncInternal (obj, fieldName, "->"), cppType), + ( retyped_ctx, + CppFunction (FuncInternal (obj, fieldName, "->"), cppType), cppType ) else if obj.cpptype = TCppGlobal then - (CppExtern (fieldName, true), cpp_type_of expr.etype) + (retyped_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 ) + ( retyped_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) + ( retyped_ctx, + CppVar (VarInternal (obj, "->", fieldName)), + cpp_type_of expr.etype ) + else (retyped_ctx, CppDynamicField (obj, fieldName), TCppVariant) | FEnum (enum, enum_field) -> - (CppEnumField (enum, enum_field), TCppEnum enum)) + (retyped_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 retyped_ctx, cppExpr = + match arg_list with + | [ { eexpr = TConst (TString code) } ] -> retyped_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 retyped_ctx, retypedArgs = List.fold_left folder (retyped_ctx, []) remaining in + retyped_ctx, CppCode (code, List.rev retypedArgs) + | _ -> abort "__cpp__'s first argument must be a string" expr.epos + in + (retyped_ctx, cppExpr, TCppCode (cpp_type_of expr.etype)) | TCall (func, args) -> ( - let retypedFunc = retype TCppUnchanged func in + let retyped_ctx, retypedFunc = retype retyped_ctx TCppUnchanged func in match retypedFunc.cpptype with - | TCppNull -> (CppNullAccess, TCppDynamic) + | TCppNull -> (retyped_ctx, CppNullAccess, TCppDynamic) | TCppFunction (argTypes, retType, _) -> - let retypedArgs = retype_function_args args argTypes in - (CppCall (FuncExpression retypedFunc, retypedArgs), retType) + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args argTypes in + (retyped_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), retType) | TCppObjCBlock (argTypes, retType) -> - let retypedArgs = retype_function_args args argTypes in - (CppCall (FuncExpression retypedFunc, retypedArgs), retType) + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args argTypes in + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + match retypedArgs with + | [ + { + cppexpr = + CppFunction + (FuncStatic (clazz, false, member), funcReturn); + }; + ] -> + (retyped_ctx, CppFunctionAddress (clazz, member), funcReturn) + | _ -> + abort + "cpp.Function.fromStaticFunction must be called on \ + static function" + expr.epos) + | CppEnumIndex _ -> + (* Not actually a TCall...*) + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + ( retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + ( retyped_ctx, + CppCall (FuncInstance (obj, InstPtr, member), retypedArgs), + return_type ) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::AddressOf" -> + let retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppReference x -> x | x -> x in + (retyped_ctx, CppAddressOf arg, TCppRawPointer ("", rawType)) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::StarOf" -> + let retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppReference x -> x | x -> x in + (retyped_ctx, CppAddressOf arg, TCppStar (rawType, false)) + | CppFunction (FuncStatic (obj, false, member), _) + when member.cf_name = "::hx::Dereference" -> + let retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let rawType = match arg.cpptype with TCppStar (x, _) -> x | x -> x in + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (* gc_stack - not needed yet *) + match return_type with + | TCppObjectArray _ | TCppScalarArray _ -> + (retyped_ctx, CppCall (FuncNew return_type, retypedArgs), return_type) + | _ -> + ( retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + match retypedArgs with + | { cppexpr = CppClassOf (path, native) } :: rest -> + ( retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_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 + *) + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_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 + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let call = + mk_cppexpr (CppCall (func, retypedArgs)) returnType + in + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (retyped_ctx, CppCall (func, retypedArgs), returnType) + | CppFunction (func, returnType) -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (retyped_ctx, CppCall (func, retypedArgs), returnType) + | CppEnumField (enum, field) -> + (* TODO - proper re-typing *) + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + ( retyped_ctx, CppCall (FuncEnumConstruct (enum, field), retypedArgs), cppType ) + | CppSuper _ -> + (* TODO - proper re-typing *) + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + ( retyped_ctx, CppCall (FuncSuperConstruct retypedFunc.cpptype, retypedArgs), TCppVoid ) + | CppDynamicField (expr, name) -> ( + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (* Special function calls *) + match (expr.cpptype, name) with + | TCppGlobal, _ -> + (retyped_ctx, CppCall (FuncExtern (name, true), retypedArgs), cppType) + | TCppString, _ -> + ( retyped_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" -> + ( retyped_ctx, + CppCall (FuncInternal (expr, "_hx_getTag", "->"), retypedArgs), + cppType ) + | _, name when is_internal_member name -> + ( retyped_ctx, CppCall (FuncInternal (expr, name, "->"), retypedArgs), cppType ) + | _ -> + (* not special *) + ( retyped_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), TCppDynamic )) + | CppExtern (name, isGlobal) -> + let arg_types = List.map (fun _ -> TCppUnchanged) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + (retyped_ctx, CppCall (FuncExtern (name, isGlobal), retypedArgs), cppType) + | _ -> + let arg_types = List.map (fun _ -> TCppDynamic) args in + let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + ( retyped_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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx 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); + (retyped_ctx, 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; - } - 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 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 retyped_ctx, cppExpr = retype retyped_ctx 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; + } + 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; + (retyped_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> - let arrayExpr, elemType = + let retyped_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 retyped_ctx, retypedObj = retype retyped_ctx TCppUnchanged e1 in + let retyped_ctx, retypedIdx = retype retyped_ctx (TCppScalar "int") e2 in + ( retyped_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 retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic e1 in + let retyped_ctx, retypedIdx = retype retyped_ctx (TCppScalar "int") e2 in match retypedObj.cpptype with | TCppScalarArray scalar -> - ( CppArray (ArrayTyped (retypedObj, retypedIdx, scalar)), + ( retyped_ctx, + CppArray (ArrayTyped (retypedObj, retypedIdx, scalar)), scalar ) | TCppPointer (_, elem) -> - (CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) + (retyped_ctx, CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) | TCppRawPointer (_, elem) -> - (CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) + (retyped_ctx, CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) | TCppObjectArray TCppDynamic -> - ( CppArray - (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), + ( retyped_ctx, + CppArray (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), TCppDynamic ) | TCppObjectArray elem -> - (CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) + (retyped_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) | TCppInst (({ cl_array_access = Some _ } as klass), _) -> - ( CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), + ( retyped_ctx, CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), cpp_type_of expr.etype ) | TCppDynamicArray -> - ( CppArray (ArrayVirtual (retypedObj, retypedIdx)), + ( retyped_ctx, + CppArray (ArrayVirtual (retypedObj, retypedIdx)), TCppDynamic ) | _ -> - ( CppArray (ArrayDynamic (retypedObj, retypedIdx)), + ( retyped_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), + ( retyped_ctx, + CppCastStatic (mk_cppexpr arrayExpr returnType, returnType), returnType ) - else (arrayExpr, elemType) + else + (retyped_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 *) @@ -992,19 +985,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) + (retyped_ctx, CppClassOf (path, is_native_gen_module module_type), TCppClass) | TBinop (op, left, right) -> ( - let binOpType = + let retyped_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 -> retyped_ctx, TCppScalar "Float" + | OpBoolAnd | OpBoolOr -> retyped_ctx, TCppScalar "bool" + | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> retyped_ctx, TCppScalar "int" + | OpAssign -> + let retyped_ctx, retyped_expr = (retype retyped_ctx TCppUnchanged left) in + (retyped_ctx, retyped_expr.cpptype) + | OpMult | OpSub -> + retyped_ctx, cpp_type_of expr.etype + | _ -> retyped_ctx, TCppUnchanged in - let e1 = retype binOpType left in - let e2 = retype binOpType right in + let retyped_ctx, e1 = retype retyped_ctx binOpType left in + let retyped_ctx, e2 = retype retyped_ctx binOpType right in let complex = is_complex_compare e1.cpptype || is_complex_compare e2.cpptype @@ -1055,8 +1051,9 @@ let expression ctx request_type function_args function_type expression_tree forI match (op, e1.cpptype, e2.cpptype) with (* Variant + Variant = Variant *) | OpAdd, _, TCppVariant | OpAdd, TCppVariant, _ -> - (reference, TCppVariant) - | _, _, _ -> (reference, cpp_type_of expr.etype)) + (retyped_ctx, reference, TCppVariant) + | _, _, _ -> + (retyped_ctx, reference, cpp_type_of expr.etype)) | TUnop (op, pre, e1) -> let targetType = match op with @@ -1065,7 +1062,7 @@ 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 retyped_ctx, e1 = retype retyped_ctx targetType e1 in let reference = match op with | Increment -> @@ -1081,22 +1078,23 @@ let expression ctx request_type function_args function_type expression_tree forI | NegBits -> CppUnop (CppNegBits, e1) | Spread -> die ~p:expr.epos "Unexpected spread operator" __LOC__ in - (reference, cpp_type_of expr.etype) + (retyped_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 + let retyped_ctx, init = retype retyped_ctx (cpp_type_of v.v_type) init in + let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block block) in declarations := old_declarations; - (CppFor (v, init, block), TCppVoid) + (retyped_ctx, CppFor (v, init, block), TCppVoid) | TWhile (e1, e2, flag) -> - let condition = retype (TCppScalar "bool") e1 in + let retyped_ctx, condition = retype retyped_ctx (TCppScalar "bool") e1 in let close = begin_loop () in - let block = retype TCppVoid (mk_block e2) in - (CppWhile (condition, block, flag, close ()), TCppVoid) + let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block e2) in + (retyped_ctx, CppWhile (condition, block, flag, close ()), 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 retyped_ctx, retypedEls = retype_function_args retyped_ctx el el_types in + (retyped_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) | TBlock expr_list -> let inject = !injection in injection := false; @@ -1110,24 +1108,25 @@ let expression ctx request_type function_args function_type expression_tree forI rev_closures := []; let local_closures = ref [] in let remaining = ref (List.length expr_list) in - let cppExprs = - List.map - (fun expr -> + let retyped_ctx, cppExprs = + List.fold_left + (fun (cur_ctx, exprs) expr -> let targetType = if inject && !remaining = 1 then cpp_type_of expr.etype else TCppVoid in decr remaining; - let result = retype targetType expr in + let new_ctx, result = retype cur_ctx targetType expr in local_closures := !rev_closures @ !local_closures; rev_closures := []; - result) + new_ctx, result :: exprs) + (retyped_ctx, []) expr_list in declarations := old_declarations; rev_closures := old_closures; - (CppBlock (cppExprs, List.rev !local_closures, !gc_stack), TCppVoid) + (retyped_ctx, CppBlock (List.rev cppExprs, List.rev !local_closures, !gc_stack), TCppVoid) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); @@ -1135,33 +1134,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) + (retyped_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 retyped_ctx, retyped_els = + List.map (fun _ -> TCppDynamic) el |> retype_function_args retyped_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 -> (retyped_ctx, CppObjectDecl (joined, false), TCppVoid) + | _ -> (retyped_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 retyped_ctx, init = + match eo with + | None -> retyped_ctx, None + | Some e -> retype retyped_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in Hashtbl.add !declarations v.v_name (); - (CppVarDecl (v, init), varType) + (retyped_ctx, CppVarDecl (v, init), varType) | TIf (ec, e1, e2) -> - let ec = retype (TCppScalar "bool") ec in + let retyped_ctx, ec = retype retyped_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 retyped_ctx, e1 = retype retyped_ctx return_type (blockify e1) in + let retyped_ctx, e2 = match e2 with - | None -> None - | Some e -> Some (retype return_type (blockify e)) + | None -> retyped_ctx, None + | Some e -> retype retyped_ctx return_type (blockify e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - ( CppIf (ec, e1, e2), + ( retyped_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 *) @@ -1175,40 +1182,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 retyped_ctx, condition = retype retyped_ctx conditionType condition in + let retyped_ctx, cppDef = match def with - | None -> None - | Some e -> Some (retype TCppVoid (mk_block e)) + | None -> retyped_ctx, None + | Some e -> retype retyped_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 retyped_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) + (retyped_ctx, []) cases in - (CppSwitch (condition, conditionType, cases, cppDef, -1), TCppVoid) + (retyped_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 retyped_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) + (retyped_ctx, []) cases in - (CppIntSwitch (condition, cases, cppDef), TCppVoid) + (retyped_ctx, CppIntSwitch (condition, List.rev cases, cppDef), TCppVoid) with Not_found -> let label = alloc_file_id () 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 retyped_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; @@ -1217,61 +1233,70 @@ 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) + (retyped_ctx, []) cases in - ( CppSwitch (condition, conditionType, cases, cppDef, label), + ( retyped_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 retyped_ctx, cppBlock = retype retyped_ctx TCppVoid try_block in + let retyped_ctx, cppCatches = + List.fold_left + (fun (retyped_ctx, acc) (tvar, catch_block) -> let old_declarations = Hashtbl.copy !declarations in Hashtbl.add !declarations tvar.v_name (); - let cppCatchBlock = retype TCppVoid catch_block in + let retyped_ctx, cppCatchBlock = retype retyped_ctx TCppVoid catch_block in declarations := old_declarations; - (tvar, cppCatchBlock)) + retyped_ctx, (tvar, cppCatchBlock) :: acc) + (retyped_ctx, []) catches in - (CppTry (cppBlock, cppCatches), TCppVoid) + (retyped_ctx, CppTry (cppBlock, List.rev cppCatches), TCppVoid) | TReturn eo -> - ( CppReturn - (match eo with - | None -> None - | Some e -> Some (retype !function_return_type e)), + let retyped_ctx, expr = match eo with + | None -> retyped_ctx, None + | Some e -> retype retyped_ctx !function_return_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in + ( retyped_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 retyped_ctx, baseCpp = retype retyped_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 *)) + (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with - | TCppObjC k -> (CppCastObjC (baseCpp, k), return_type) + | TCppObjC k -> (retyped_ctx, CppCastObjC (baseCpp, k), return_type) | TCppPointer (_, _) | TCppRawPointer (_, _) | TCppStar _ | TCppInst _ -> - (CppCast (baseCpp, return_type), return_type) - | TCppString -> (CppCastScalar (baseCpp, "::String"), return_type) + (retyped_ctx, CppCast (baseCpp, return_type), return_type) + | TCppString -> (retyped_ctx, CppCastScalar (baseCpp, "::String"), return_type) | TCppCode t when baseStr <> tcpp_to_string t -> - (CppCast (baseCpp, t), t) - | TCppNativePointer klass -> (CppCastNative baseCpp, return_type) + (retyped_ctx, CppCast (baseCpp, t), t) + | TCppNativePointer klass -> (retyped_ctx, CppCastNative baseCpp, return_type) | TCppObjCBlock (args, ret) -> - (CppCastObjCBlock (baseCpp, args, ret), return_type) - | TCppProtocol p -> (CppCastProtocol (baseCpp, p), return_type) + (retyped_ctx, CppCastObjCBlock (baseCpp, args, ret), return_type) + | TCppProtocol p -> (retyped_ctx, CppCastProtocol (baseCpp, p), return_type) | TCppDynamic when baseCpp.cpptype = TCppClass -> - (CppCast (baseCpp, TCppDynamic), TCppDynamic) - | _ -> (baseCpp.cppexpr, baseCpp.cpptype (* use autocasting rules *)) + (retyped_ctx, CppCast (baseCpp, TCppDynamic), TCppDynamic) + | _ -> (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype (* use autocasting rules *)) ) | TCast (base, Some t) -> ( - let baseCpp = retype (cpp_type_of base.etype) base in + let retyped_ctx, baseCpp = retype retyped_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 @@ -1283,71 +1308,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 *)) + (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with - | TCppNativePointer klass -> (CppCastNative baseCpp, return_type) + | TCppNativePointer klass -> + ( retyped_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)) + (retyped_ctx, CppTCast (baseCpp, cpp_type_of expr.etype), return_type) + | TCppDynamic -> + (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype) + | _ -> + (retyped_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 + retyped_ctx, mk_cppexpr retypedExpr TCppVoid else if return_type = TCppVarArg then match cpp_variant_type_of cppExpr.cpptype with - | TCppVoidStar | TCppScalar _ -> cppExpr + | TCppVoidStar | TCppScalar _ -> retyped_ctx, cppExpr | TCppString -> - mk_cppexpr + retyped_ctx, mk_cppexpr (CppVar (VarInternal (cppExpr, ".", "raw_ptr()"))) (TCppPointer ("ConstPointer", TCppScalar "char")) - | TCppDynamic -> mk_cppexpr (CppCastNative cppExpr) TCppVoidStar + | TCppDynamic -> retyped_ctx, mk_cppexpr (CppCastNative cppExpr) TCppVoidStar | _ -> let toDynamic = mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic in - mk_cppexpr (CppCastNative toDynamic) TCppVoidStar + retyped_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 -> retyped_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, [])) + retyped_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 + retyped_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type + | TCppObjC k -> retyped_ctx, mk_cppexpr (CppCastObjC (cppExpr, k)) return_type | TCppObjCBlock (ret, args) -> - mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type + retyped_ctx, mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type | TCppScalar scalar -> - mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type + retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type | TCppString -> - mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type + retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type | TCppInterface _ when cppExpr.cpptype = TCppVariant -> - mk_cppexpr (CppCastVariant cppExpr) return_type + retyped_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type | TCppDynamic when cppExpr.cpptype = TCppVariant -> - mk_cppexpr (CppCastVariant cppExpr) return_type + retyped_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 + retyped_ctx, mk_cppexpr (CppCast (ptrCast, TCppStar (t, const))) (TCppStar (t, const)) - | _ -> cppExpr + | _ -> retyped_ctx, cppExpr else match (cppExpr.cpptype, return_type) with - | _, TCppUnchanged -> cppExpr + | _, TCppUnchanged -> retyped_ctx, cppExpr (* Using the 'typedef hack', where we use typedef X = T, allows the haxe compiler to use these types interchangeably. We then work @@ -1378,58 +1407,58 @@ 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 + retyped_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 _ -> retyped_ctx, cppExpr + | TCppReference TCppDynamic, t -> retyped_ctx, mk_cppexpr retypedExpr (TCppReference t) + | TCppStar (TCppDynamic, _), TCppStar (_, _) -> retyped_ctx, cppExpr | TCppStar (TCppDynamic, const), t -> - mk_cppexpr retypedExpr (TCppStar (t, const)) + retyped_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 + retyped_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 + retyped_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 + retyped_ctx, mk_cppexpr (CppNewNative cppExpr) return_type | TCppInst _, TCppStar (p, const) | TCppStruct _, TCppStar (p, const) -> - mk_cppexpr (CppAddressOf cppExpr) return_type - | TCppObjectPtr, TCppObjectPtr -> cppExpr + retyped_ctx, mk_cppexpr (CppAddressOf cppExpr) return_type + | TCppObjectPtr, TCppObjectPtr -> retyped_ctx, cppExpr | TCppObjectPtr, _ -> - mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic - | TCppProtocol _, TCppProtocol _ -> cppExpr + retyped_ctx, mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic + | TCppProtocol _, TCppProtocol _ -> retyped_ctx, cppExpr | t, TCppProtocol protocol -> - mk_cppexpr (CppCastProtocol (cppExpr, protocol)) return_type + retyped_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 + retyped_ctx, mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic | _, TCppObjectPtr -> - mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr + retyped_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 + retyped_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type | TCppScalar from, TCppScalar too when from <> too -> - mk_cppexpr (CppCastScalar (cppExpr, too)) return_type - | _ -> cppExpr + retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type + | _ -> retyped_ctx, cppExpr in - retype request_type expression_tree + retype () request_type expression_tree |> snd let rec get_id path ids = let class_name = class_text path in From 89bc3b8048cd1c40f552a456f936851112d02bf0 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 17:19:29 +0000 Subject: [PATCH 88/97] closures tracked in retyper ctx --- src/generators/cpp/cppRetyper.ml | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index d602aabf0bf..67569c32ab8 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -181,9 +181,12 @@ 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; +} + 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 @@ -365,7 +368,7 @@ let expression ctx request_type function_args function_type expression_tree forI in (* Core Retyping *) - let rec retype (retyped_ctx:unit) return_type expr = + let rec retype retyped_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 } @@ -907,14 +910,14 @@ let expression ctx request_type function_args function_type expression_tree forI let result = { close_expr = cppExpr; - close_id = !closureId; + close_id = retyped_ctx.closure_id; close_undeclared = !undeclared; close_type = ret; close_args = func.tf_args; close_this = !uses_this; } in - incr closureId; + let new_ctx = { retyped_ctx with closure_id = retyped_ctx.closure_id + 1; closures = result :: retyped_ctx.closures } in declarations := old_declarations; undeclared := old_undeclared; Hashtbl.iter @@ -927,8 +930,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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; - (retyped_ctx, CppClosure result, TCppDynamic) + (new_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> let retyped_ctx, arrayExpr, elemType = match cpp_is_native_array_access (cpp_type_of e1.etype) with @@ -1104,11 +1106,9 @@ let expression ctx request_type function_args function_type expression_tree forI ^ 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 retyped_ctx, cppExprs = + let new_ctx = { retyped_ctx with closures = [] } in + let new_ctx, cppExprs = List.fold_left (fun (cur_ctx, exprs) expr -> let targetType = @@ -1117,16 +1117,13 @@ let expression ctx request_type function_args function_type expression_tree forI in decr remaining; let new_ctx, result = retype cur_ctx targetType expr in - local_closures := !rev_closures @ !local_closures; - rev_closures := []; new_ctx, result :: exprs) - (retyped_ctx, []) + (new_ctx, []) expr_list in declarations := old_declarations; - rev_closures := old_closures; - (retyped_ctx, CppBlock (List.rev cppExprs, List.rev !local_closures, !gc_stack), TCppVoid) + ({ retyped_ctx with closure_id = new_ctx.closure_id }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, !gc_stack), TCppVoid) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); @@ -1458,7 +1455,7 @@ let expression ctx request_type function_args function_type expression_tree forI retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type | _ -> retyped_ctx, cppExpr in - retype () request_type expression_tree |> snd + retype { closure_id = 0; closures = [] } request_type expression_tree |> snd let rec get_id path ids = let class_name = class_text path in From a9cb03e4c5f8105822ed7821161b6fbec5b6ebde Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 17:54:09 +0000 Subject: [PATCH 89/97] injection stored in retyper ctx --- src/generators/cpp/cppRetyper.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 67569c32ab8..59844bedc09 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -184,6 +184,7 @@ let cpp_instance_type = cpp_instance_type [] type retyper_ctx = { closure_id : int; closures : tcpp_closure list; + injection : bool; } let expression ctx request_type function_args function_type expression_tree forInjection = @@ -191,7 +192,6 @@ let expression ctx request_type function_args function_type expression_tree forI 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 @@ -1098,8 +1098,7 @@ let expression ctx request_type function_args function_type expression_tree forI let retyped_ctx, retypedEls = retype_function_args retyped_ctx el el_types in (retyped_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) | TBlock expr_list -> - let inject = !injection in - injection := false; + let inject = retyped_ctx.injection in if return_type <> TCppVoid && not forCppia then print_endline ("Value from a block not handled " ^ expr.epos.pfile ^ " " @@ -1107,7 +1106,7 @@ let expression ctx request_type function_args function_type expression_tree forI let old_declarations = Hashtbl.copy !declarations in let remaining = ref (List.length expr_list) in - let new_ctx = { retyped_ctx with closures = [] } in + let new_ctx = { retyped_ctx with closures = []; injection = false } in let new_ctx, cppExprs = List.fold_left (fun (cur_ctx, exprs) expr -> @@ -1123,7 +1122,7 @@ let expression ctx request_type function_args function_type expression_tree forI in declarations := old_declarations; - ({ retyped_ctx with closure_id = new_ctx.closure_id }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, !gc_stack), TCppVoid) + ({ retyped_ctx with closure_id = new_ctx.closure_id; injection = false }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, !gc_stack), TCppVoid) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); @@ -1455,7 +1454,7 @@ let expression ctx request_type function_args function_type expression_tree forI retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type | _ -> retyped_ctx, cppExpr in - retype { closure_id = 0; closures = [] } request_type expression_tree |> snd + retype { closure_id = 0; closures = []; injection = forInjection } request_type expression_tree |> snd let rec get_id path ids = let class_name = class_text path in From 8b1792b5a1e4de6bcf211e18398541442f5bd146 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 20:43:38 +0000 Subject: [PATCH 90/97] declarations track by retyper ctx --- src/generators/cpp/cppAst.ml | 2 +- src/generators/cpp/cppRetyper.ml | 102 ++++++++++++++++++------------- src/generators/cpp/gen/cppGen.ml | 6 +- 3 files changed, 65 insertions(+), 45 deletions(-) diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index 66816a1cf08..d8f2ec06c73 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -86,7 +86,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; } diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 59844bedc09..3714560c2b1 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -185,11 +185,11 @@ type retyper_ctx = { closure_id : int; closures : tcpp_closure list; injection : bool; + declarations : unit StringMap.t; + undeclared : tvar StringMap.t; } let expression ctx request_type function_args function_type expression_tree forInjection = - 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 this_real = ref (if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic) in @@ -212,8 +212,13 @@ let expression ctx request_type function_args function_type expression_tree forI in (* '__trace' is at the top-level *) - Hashtbl.add !declarations "__trace" (); - List.iter (fun arg -> Hashtbl.add !declarations arg.v_name ()) function_args; + let initial_ctx = { + closures = []; + closure_id = 0; + injection = forInjection; + undeclared = StringMap.empty; + declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.of_list |> StringMap.add "__trace" (); + } in (* Helper functions *) @@ -414,16 +419,14 @@ let expression ctx request_type function_args function_type expression_tree forI (retyped_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);*) + if StringMap.mem name retyped_ctx.declarations then (retyped_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 = { retyped_ctx with undeclared = StringMap.add name tvar retyped_ctx.undeclared } in if has_var_flag tvar VCaptured then - (retyped_ctx, CppVar (VarClosure tvar), cpp_type_of tvar.v_type) + (new_ctx, CppVar (VarClosure tvar), cpp_type_of tvar.v_type) else - (retyped_ctx, CppExtern (name, false), cpp_type_of tvar.v_type)) + (new_ctx, CppExtern (name, false), cpp_type_of tvar.v_type)) | TIdent name -> (retyped_ctx, CppExtern (name, false), return_type) | TBreak -> ( if forCppia then @@ -893,44 +896,51 @@ let expression ctx request_type function_args function_type expression_tree forI 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 retyped_ctx, cppExpr = retype retyped_ctx TCppVoid (mk_block func.tf_expr) in + + let new_ctx = { + retyped_ctx with + declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> StringMap.of_list; + undeclared = StringMap.empty; + } in + let new_ctx, cppExpr = retype new_ctx TCppVoid (mk_block func.tf_expr) in + let result = { close_expr = cppExpr; close_id = retyped_ctx.closure_id; - close_undeclared = !undeclared; + close_undeclared = new_ctx.undeclared; close_type = ret; close_args = func.tf_args; close_this = !uses_this; } in - let new_ctx = { retyped_ctx with closure_id = retyped_ctx.closure_id + 1; closures = result :: retyped_ctx.closures } in - 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; + let folder acc (name, tvar) = + if not (StringMap.mem name retyped_ctx.declarations) then + StringMap.add name tvar acc + else + acc + in + let new_undeclared = + List.fold_left + folder + retyped_ctx.undeclared + (StringMap.bindings new_ctx.undeclared) + in + + let retyped_ctx = { retyped_ctx with closure_id = retyped_ctx.closure_id + 1; closures = result :: retyped_ctx.closures; undeclared = new_undeclared } in + 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; - (new_ctx, CppClosure result, TCppDynamic) + (retyped_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> let retyped_ctx, arrayExpr, elemType = match cpp_is_native_array_access (cpp_type_of e1.etype) with @@ -1082,11 +1092,10 @@ let expression ctx request_type function_args function_type expression_tree forI in (retyped_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 retyped_ctx = { retyped_ctx with declarations = StringMap.add v.v_name () retyped_ctx.declarations } in let retyped_ctx, init = retype retyped_ctx (cpp_type_of v.v_type) init in let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block block) in - declarations := old_declarations; + let retyped_ctx = { retyped_ctx with declarations = StringMap.remove v.v_name retyped_ctx.declarations } in (retyped_ctx, CppFor (v, init, block), TCppVoid) | TWhile (e1, e2, flag) -> let retyped_ctx, condition = retype retyped_ctx (TCppScalar "bool") e1 in @@ -1098,20 +1107,18 @@ let expression ctx request_type function_args function_type expression_tree forI let retyped_ctx, retypedEls = retype_function_args retyped_ctx el el_types in (retyped_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) | TBlock expr_list -> - let inject = retyped_ctx.injection in 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 remaining = ref (List.length expr_list) in let new_ctx = { retyped_ctx with closures = []; injection = false } in let new_ctx, cppExprs = List.fold_left (fun (cur_ctx, exprs) expr -> let targetType = - if inject && !remaining = 1 then cpp_type_of expr.etype + if retyped_ctx.injection && !remaining = 1 then cpp_type_of expr.etype else TCppVoid in decr remaining; @@ -1120,9 +1127,23 @@ let expression ctx request_type function_args function_type expression_tree forI (new_ctx, []) expr_list in - declarations := old_declarations; - ({ retyped_ctx with closure_id = new_ctx.closure_id; injection = false }, CppBlock (List.rev cppExprs, List.rev new_ctx.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 retyped_ctx.declarations) then + StringMap.add name tvar acc + else + acc + in + let new_undeclared = + List.fold_left + folder + retyped_ctx.undeclared + (StringMap.bindings new_ctx.undeclared) + in + + ({ retyped_ctx with injection = false; declarations = retyped_ctx.declarations; undeclared = new_undeclared }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, !gc_stack), TCppVoid) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); @@ -1150,7 +1171,7 @@ let expression ctx request_type function_args function_type expression_tree forI | None -> retyped_ctx, None | Some e -> retype retyped_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - Hashtbl.add !declarations v.v_name (); + let retyped_ctx = { retyped_ctx with declarations = StringMap.add v.v_name () retyped_ctx.declarations } in (retyped_ctx, CppVarDecl (v, init), varType) | TIf (ec, e1, e2) -> let retyped_ctx, ec = retype retyped_ctx (TCppScalar "bool") ec in @@ -1249,10 +1270,9 @@ let expression ctx request_type function_args function_type expression_tree forI let retyped_ctx, cppCatches = List.fold_left (fun (retyped_ctx, acc) (tvar, catch_block) -> - let old_declarations = Hashtbl.copy !declarations in - Hashtbl.add !declarations tvar.v_name (); + let retyped_ctx = { retyped_ctx with declarations = StringMap.add tvar.v_name () retyped_ctx.declarations } in let retyped_ctx, cppCatchBlock = retype retyped_ctx TCppVoid catch_block in - declarations := old_declarations; + let retyped_ctx = { retyped_ctx with declarations = StringMap.remove tvar.v_name retyped_ctx.declarations } in retyped_ctx, (tvar, cppCatchBlock) :: acc) (retyped_ctx, []) catches @@ -1454,7 +1474,7 @@ let expression ctx request_type function_args function_type expression_tree forI retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type | _ -> retyped_ctx, cppExpr in - retype { closure_id = 0; closures = []; injection = forInjection } request_type expression_tree |> snd + retype initial_ctx request_type expression_tree |> snd let rec get_id path ids = let class_name = class_text path in diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index e6775227c22..8cfb76d418d 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -945,7 +945,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 := ","; @@ -1462,7 +1462,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | 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 *) @@ -1475,7 +1475,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; From b800eb0151554067be47b6dd5415c17a48dbd484 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 20:57:40 +0000 Subject: [PATCH 91/97] this handling moved into ctx --- src/generators/cpp/cppRetyper.ml | 37 +++++++++++++++++--------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 3714560c2b1..8ca6cb5a971 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -187,12 +187,12 @@ type retyper_ctx = { injection : bool; declarations : unit StringMap.t; undeclared : tvar StringMap.t; + uses_this : tcppthis option; + this_real : tcppthis; } let expression ctx request_type function_args function_type expression_tree forInjection = - let uses_this = ref None in let gc_stack = ref false 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 @@ -218,6 +218,8 @@ let expression ctx request_type function_args function_type expression_tree forI injection = forInjection; undeclared = StringMap.empty; declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.of_list |> StringMap.add "__trace" (); + uses_this = None; + this_real = if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic; } in (* Helper functions *) @@ -401,16 +403,16 @@ let expression ctx request_type function_args function_type expression_tree forI let retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic enumObj in (retyped_ctx, CppEnumIndex retypedObj, TCppScalar "int") | TConst TThis -> - uses_this := Some !this_real; + let retyped_ctx = { retyped_ctx with uses_this = Some retyped_ctx.this_real } in ( retyped_ctx, - CppThis !this_real, - if !this_real = ThisDynamic then TCppDynamic + CppThis retyped_ctx.this_real, + if retyped_ctx.this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) | TConst TSuper -> - uses_this := Some !this_real; + let retyped_ctx = { retyped_ctx with uses_this = Some retyped_ctx.this_real } in ( retyped_ctx, - CppSuper !this_real, - if !this_real = ThisDynamic then TCppDynamic + CppSuper retyped_ctx.this_real, + if retyped_ctx.this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) | TConst TNull when is_objc_type expr.etype -> (retyped_ctx, CppNil, TCppNull) | TConst x -> cpp_const_type retyped_ctx x @@ -893,20 +895,18 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> false); (retyped_ctx, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> - let old_this_real = !this_real in - this_real := ThisFake; (* TODO - this_dynamic ? *) - 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; let new_ctx = { retyped_ctx with declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> StringMap.of_list; undeclared = StringMap.empty; + this_real = ThisFake; + uses_this = None; } in let new_ctx, cppExpr = retype new_ctx TCppVoid (mk_block func.tf_expr) in @@ -917,7 +917,7 @@ let expression ctx request_type function_args function_type expression_tree forI close_undeclared = new_ctx.undeclared; close_type = ret; close_args = func.tf_args; - close_this = !uses_this; + close_this = new_ctx.uses_this; } in let folder acc (name, tvar) = @@ -933,12 +933,15 @@ let expression ctx request_type function_args function_type expression_tree forI (StringMap.bindings new_ctx.undeclared) in - let retyped_ctx = { retyped_ctx with closure_id = retyped_ctx.closure_id + 1; closures = result :: retyped_ctx.closures; undeclared = new_undeclared } in + let retyped_ctx = { + retyped_ctx with + closure_id = retyped_ctx.closure_id + 1; + closures = result :: retyped_ctx.closures; + undeclared = new_undeclared; + uses_this = if new_ctx.uses_this != None then Some retyped_ctx.this_real else retyped_ctx.uses_this; + } in 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; (retyped_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> From 71b4d54b71d633296276d7230d20d66806e6e07b Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 21:16:16 +0000 Subject: [PATCH 92/97] gc stack handled by retyper ctx --- src/generators/cpp/cppRetyper.ml | 101 ++++++++++++++++--------------- 1 file changed, 53 insertions(+), 48 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 8ca6cb5a971..4acccf28440 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -189,10 +189,10 @@ type retyper_ctx = { undeclared : tvar StringMap.t; uses_this : tcppthis option; this_real : tcppthis; + gc_stack : bool; } let expression ctx request_type function_args function_type expression_tree forInjection = - let gc_stack = ref false 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 @@ -220,6 +220,7 @@ let expression ctx request_type function_args function_type expression_tree forI declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.of_list |> StringMap.add "__trace" (); uses_this = None; this_real = if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic; + gc_stack = false; } in (* Helper functions *) @@ -887,16 +888,13 @@ let expression ctx request_type function_args function_type expression_tree forI let arg_types, _ = cpp_function_type_of_args_ret constructor_type in let retyped_ctx, retypedArgs = retype_function_args retyped_ctx 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); - (retyped_ctx, CppCall (FuncNew created_type, retypedArgs), created_type) + let gc_stack = + retyped_ctx.gc_stack || match created_type with + | TCppInst (t, _) -> not (is_native_class t) + | _ -> false in + ({ retyped_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> (* TODO - this_dynamic ? *) - 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; @@ -942,7 +940,6 @@ let expression ctx request_type function_args function_type expression_tree forI } in function_return_type := old_return_type; - gc_stack := old_gc_stack; (retyped_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> let retyped_ctx, arrayExpr, elemType = @@ -1028,40 +1025,40 @@ 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 retyped_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 { retyped_ctx with gc_stack = true } else retyped_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 { retyped_ctx with gc_stack = true } else retyped_ctx in + new_ctx, CppModify (op, lvalue, e2) + | OpEq when e1_null && e2_null -> retyped_ctx, CppBool true + | OpGte when e1_null && e2_null -> retyped_ctx, CppBool true + | OpLte when e1_null && e2_null -> retyped_ctx, CppBool true + | OpNotEq when e1_null && e2_null -> retyped_ctx, CppBool false + | _ when e1_null && e2_null -> retyped_ctx, CppBool false + | OpEq when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) + | OpGte when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) + | OpLte when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) + | OpNotEq when e1_null -> retyped_ctx, CppNullCompare ("IsNotNull", e2) + | OpEq when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) + | OpGte when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) + | OpLte when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) + | OpNotEq when e2_null -> retyped_ctx, CppNullCompare ("IsNotNull", e1) + | OpEq when instance -> retyped_ctx, CppCompare ("IsInstanceEq", e1, e2, op) + | OpNotEq when instance -> retyped_ctx, CppCompare ("IsInstanceNotEq", e1, e2, op) + | OpEq when pointer -> retyped_ctx, CppCompare ("IsPointerEq", e1, e2, op) + | OpNotEq when pointer -> retyped_ctx, CppCompare ("IsPointerNotEq", e1, e2, op) + | OpEq when complex -> retyped_ctx, CppCompare ("IsEq", e1, e2, op) + | OpNotEq when complex -> retyped_ctx, CppCompare ("IsNotEq", e1, e2, op) + | OpGte when complex -> retyped_ctx, CppCompare ("IsGreaterEq", e1, e2, op) + | OpLte when complex -> retyped_ctx, CppCompare ("IsLessEq", e1, e2, op) + | OpGt when complex -> retyped_ctx, CppCompare ("IsGreater", e1, e2, op) + | OpLt when complex -> retyped_ctx, CppCompare ("IsLess", e1, e2, op) + | _ -> retyped_ctx, CppBinop (op, e1, e2) in match (op, e1.cpptype, e2.cpptype) with (* Variant + Variant = Variant *) @@ -1078,19 +1075,19 @@ let expression ctx request_type function_args function_type expression_tree forI in let retyped_ctx, e1 = retype retyped_ctx targetType e1 in - let reference = + let retyped_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 { retyped_ctx with gc_stack = true } else retyped_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 { retyped_ctx with gc_stack = true } else retyped_ctx in + new_ctx, CppCrement (CppDecrement, pre, lvalue) + | Neg -> retyped_ctx, CppUnop (CppNeg, e1) + | Not -> retyped_ctx, CppUnop (CppNot, e1) + | NegBits -> retyped_ctx, CppUnop (CppNegBits, e1) | Spread -> die ~p:expr.epos "Unexpected spread operator" __LOC__ in (retyped_ctx, reference, cpp_type_of expr.etype) @@ -1146,7 +1143,15 @@ let expression ctx request_type function_args function_type expression_tree forI (StringMap.bindings new_ctx.undeclared) in - ({ retyped_ctx with injection = false; declarations = retyped_ctx.declarations; undeclared = new_undeclared }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, !gc_stack), TCppVoid) + ( + { retyped_ctx with + injection = false; + declarations = retyped_ctx.declarations; + undeclared = new_undeclared; + gc_stack = new_ctx.gc_stack }, + CppBlock (List.rev cppExprs, List.rev new_ctx.closures, new_ctx.gc_stack), + TCppVoid + ) | TObjectDecl [ (("fileName", _, _), { eexpr = TConst (TString file) }); From 36718d8f30a7e3e3dad0f56b6440308f2dd9e41c Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 21:23:17 +0000 Subject: [PATCH 93/97] function return type handled by retyper ctx --- src/generators/cpp/cppRetyper.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 4acccf28440..ead601d0c7d 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -190,11 +190,11 @@ type retyper_ctx = { uses_this : tcppthis option; this_real : tcppthis; gc_stack : bool; + function_return_type: tcpp; } let expression ctx request_type function_args function_type expression_tree forInjection = 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 () = @@ -221,6 +221,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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; } in (* Helper functions *) @@ -895,9 +896,6 @@ let expression ctx request_type function_args function_type expression_tree forI ({ retyped_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> (* TODO - this_dynamic ? *) - let old_return_type = !function_return_type in - let ret = cpp_type_of func.tf_type in - function_return_type := ret; let new_ctx = { retyped_ctx with @@ -905,6 +903,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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 @@ -913,7 +912,7 @@ let expression ctx request_type function_args function_type expression_tree forI close_expr = cppExpr; close_id = retyped_ctx.closure_id; close_undeclared = new_ctx.undeclared; - close_type = ret; + close_type = new_ctx.function_return_type; close_args = func.tf_args; close_this = new_ctx.uses_this; } @@ -939,7 +938,6 @@ let expression ctx request_type function_args function_type expression_tree forI uses_this = if new_ctx.uses_this != None then Some retyped_ctx.this_real else retyped_ctx.uses_this; } in - function_return_type := old_return_type; (retyped_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> let retyped_ctx, arrayExpr, elemType = @@ -1289,7 +1287,7 @@ let expression ctx request_type function_args function_type expression_tree forI | TReturn eo -> let retyped_ctx, expr = match eo with | None -> retyped_ctx, None - | Some e -> retype retyped_ctx !function_return_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in + | Some e -> retype retyped_ctx retyped_ctx.function_return_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in ( retyped_ctx, CppReturn expr, TCppVoid ) From 4b10c5eb218e0ff9ac44a964cc63d1d555641b40 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 22:41:36 +0000 Subject: [PATCH 94/97] move loop goto management into retyper ctx --- src/generators/cpp/cppRetyper.ml | 69 ++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 30 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index ead601d0c7d..c301cbc923b 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -190,42 +190,51 @@ type retyper_ctx = { uses_this : tcppthis option; this_real : tcppthis; gc_stack : bool; - function_return_type: tcpp; + 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 file_id = ctx.ctx_file_id 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 - in - - (* '__trace' is at the top-level *) let initial_ctx = { closures = []; closure_id = 0; injection = forInjection; undeclared = StringMap.empty; - declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.of_list |> StringMap.add "__trace" (); + declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.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 + + 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 + + new_ctx, resolver + in + let cpp_const_type retyped_ctx cval = match cval with | TInt i -> (retyped_ctx, CppInt i, TCppScalar "int") @@ -436,11 +445,11 @@ let expression ctx request_type function_args function_type expression_tree forI if forCppia then (retyped_ctx, CppBreak, TCppVoid) else - match !loop_stack with - | [] -> (retyped_ctx, CppBreak, TCppVoid) - | (label_id, used) :: _ -> - used := true; - (retyped_ctx, CppGoto label_id, TCppVoid)) + match retyped_ctx.loop_stack with + | [] -> + (retyped_ctx, CppBreak, TCppVoid) + | (label_id, used) :: tl -> + ({ retyped_ctx with loop_stack = (label_id, true) :: tl }, CppGoto label_id, TCppVoid)) | TContinue -> (retyped_ctx, CppContinue, TCppVoid) | TThrow e1 -> let retyped_ctx, retyped_expr = retype retyped_ctx TCppDynamic e1 in @@ -1097,9 +1106,10 @@ let expression ctx request_type function_args function_type expression_tree forI (retyped_ctx, CppFor (v, init, block), TCppVoid) | TWhile (e1, e2, flag) -> let retyped_ctx, condition = retype retyped_ctx (TCppScalar "bool") e1 in - let close = begin_loop () in + let retyped_ctx, close = begin_loop retyped_ctx in let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block e2) in - (retyped_ctx, CppWhile (condition, block, flag, close ()), TCppVoid) + let retyped_ctx, id = close retyped_ctx in + (retyped_ctx, CppWhile (condition, block, flag, id), TCppVoid) | TArrayDecl el -> let el_types = List.map (fun _ -> TCppDynamic) el in let retyped_ctx, retypedEls = retype_function_args retyped_ctx el el_types in @@ -1142,11 +1152,10 @@ let expression ctx request_type function_args function_type expression_tree forI in ( - { retyped_ctx with - injection = false; + { new_ctx with declarations = retyped_ctx.declarations; undeclared = new_undeclared; - gc_stack = new_ctx.gc_stack }, + closures = retyped_ctx.closures }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, new_ctx.gc_stack), TCppVoid ) @@ -1242,7 +1251,7 @@ let expression ctx request_type function_args function_type expression_tree forI in (retyped_ctx, CppIntSwitch (condition, List.rev cases, cppDef), TCppVoid) with Not_found -> - let label = alloc_file_id () in + let retyped_ctx, label = alloc_file_id retyped_ctx in (* do something better maybe ... *) let retyped_ctx, cases = List.fold_left From b15f5277c1cb5898e6fe3d071b768a790afa29e1 Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Thu, 28 Nov 2024 22:42:58 +0000 Subject: [PATCH 95/97] consistent retyper ctx variable name --- src/generators/cpp/cppRetyper.ml | 648 +++++++++++++++---------------- 1 file changed, 324 insertions(+), 324 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index c301cbc923b..1d655af940c 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -235,15 +235,15 @@ let expression ctx request_type function_args function_type expression_tree forI new_ctx, resolver in - let cpp_const_type retyped_ctx cval = + let cpp_const_type retyper_ctx cval = match cval with - | TInt i -> (retyped_ctx, CppInt i, TCppScalar "int") - | TBool b -> (retyped_ctx, CppBool b, TCppScalar "bool") - | TFloat f -> (retyped_ctx, CppFloat (Texpr.replace_separators f ""), TCppScalar "Float") - | TString s -> (retyped_ctx, 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 *) - (retyped_ctx, CppNull, TCppNull) + (retyper_ctx, CppNull, TCppNull) in let cpp_return_type haxe_type = @@ -386,118 +386,118 @@ let expression ctx request_type function_args function_type expression_tree forI in (* Core Retyping *) - let rec retype retyped_ctx 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 retyped_ctx args arg_types = + 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 arg_types - |> ExtList.List.fold_left2 folder (retyped_ctx, []) args + |> ExtList.List.fold_left2 folder (retyper_ctx, []) args |> fun (ctx, acc) -> (ctx, List.rev acc) in - let retyped_ctx, retypedExpr, retypedType = + let retyper_ctx, retypedExpr, retypedType = match expr.eexpr with | TEnumParameter (enumObj, enumField, enumIndex) -> - let retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic enumObj in - ( retyped_ctx, + 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 retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic enumObj in - (retyped_ctx, CppEnumIndex retypedObj, TCppScalar "int") + let retyper_ctx, retypedObj = retype retyper_ctx TCppDynamic enumObj in + (retyper_ctx, CppEnumIndex retypedObj, TCppScalar "int") | TConst TThis -> - let retyped_ctx = { retyped_ctx with uses_this = Some retyped_ctx.this_real } in - ( retyped_ctx, - CppThis retyped_ctx.this_real, - if retyped_ctx.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 -> - let retyped_ctx = { retyped_ctx with uses_this = Some retyped_ctx.this_real } in - ( retyped_ctx, - CppSuper retyped_ctx.this_real, - if retyped_ctx.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 -> (retyped_ctx, CppNil, TCppNull) - | TConst x -> cpp_const_type retyped_ctx 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 *) - (retyped_ctx, CppClassOf (([], ""), false), TCppGlobal) + (retyper_ctx, CppClassOf (([], ""), false), TCppGlobal) | TLocal tvar -> let name = tvar.v_name in - if StringMap.mem name retyped_ctx.declarations then - (retyped_ctx, 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 ( - let new_ctx = { retyped_ctx with undeclared = StringMap.add name tvar retyped_ctx.undeclared } in + let new_ctx = { retyper_ctx with undeclared = StringMap.add name tvar retyper_ctx.undeclared } in if has_var_flag tvar VCaptured then (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 -> (retyped_ctx, CppExtern (name, false), return_type) + | TIdent name -> (retyper_ctx, CppExtern (name, false), return_type) | TBreak -> ( if forCppia then - (retyped_ctx, CppBreak, TCppVoid) + (retyper_ctx, CppBreak, TCppVoid) else - match retyped_ctx.loop_stack with + match retyper_ctx.loop_stack with | [] -> - (retyped_ctx, CppBreak, TCppVoid) + (retyper_ctx, CppBreak, TCppVoid) | (label_id, used) :: tl -> - ({ retyped_ctx with loop_stack = (label_id, true) :: tl }, CppGoto label_id, TCppVoid)) - | TContinue -> (retyped_ctx, CppContinue, TCppVoid) + ({ retyper_ctx with loop_stack = (label_id, true) :: tl }, CppGoto label_id, TCppVoid)) + | TContinue -> (retyper_ctx, CppContinue, TCppVoid) | TThrow e1 -> - let retyped_ctx, retyped_expr = retype retyped_ctx TCppDynamic e1 in - (retyped_ctx, CppThrow retyped_expr, TCppVoid) + let retyper_ctx, retyped_expr = retype retyper_ctx TCppDynamic e1 in + (retyper_ctx, CppThrow retyped_expr, TCppVoid) | TMeta ((Meta.Fixed, _, _), e) -> ( - let retyped_ctx, cppType = retype retyped_ctx return_type e in + let retyper_ctx, cppType = retype retyper_ctx return_type e in match cppType.cppexpr with | CppObjectDecl (def, false) -> - (retyped_ctx, CppObjectDecl (def, true), cppType.cpptype) + (retyper_ctx, CppObjectDecl (def, true), cppType.cpptype) | _ -> - (retyped_ctx, cppType.cppexpr, cppType.cpptype)) + (retyper_ctx, cppType.cppexpr, cppType.cpptype)) | TMeta (_, e) | TParenthesis e -> - let retyped_ctx, cppType = retype retyped_ctx return_type e in - (retyped_ctx, 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 retyped_ctx, retypedObj = retype retyped_ctx clazzType obj 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 - (retyped_ctx, CppNullAccess, TCppDynamic) + (retyper_ctx, CppNullAccess, TCppDynamic) else if retypedObj.cpptype = TCppDynamic && not (has_class_flag clazz CInterface) then if is_internal_member member.cf_name then - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInstance (retypedObj, InstPtr, member), funcReturn), exprType ) else - (retyped_ctx, CppDynamicField (retypedObj, member.cf_name), TCppVariant) + (retyper_ctx, CppDynamicField (retypedObj, member.cf_name), TCppVariant) else if cpp_is_struct_access retypedObj.cpptype then match retypedObj.cppexpr with | CppThis ThisReal -> - (retyped_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + (retyper_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) | CppSuper this -> - ( retyped_ctx, + ( retyper_ctx, CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), exprType ) | _ -> if is_var_field member then - ( retyped_ctx, + ( retyper_ctx, CppVar (VarInstance (retypedObj, member, tcpp_to_string clazzType, ".")), exprType ) else - ( retyped_ctx, + ( retyper_ctx, CppFunction ( FuncInstance (retypedObj, InstStruct, member), funcReturn ), exprType ) else if is_var_field member then @@ -513,20 +513,20 @@ let expression ctx request_type function_args function_type expression_tree forI match retypedObj.cppexpr with | CppThis ThisReal -> - (retyped_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) + (retyper_ctx, CppVar (VarThis (member, retypedObj.cpptype)), exprType) | _ -> ( match (retypedObj.cpptype, member.cf_name) with (* Special variable remapping ... *) | TCppDynamicArray, "length" when not forCppia -> - ( retyped_ctx, + ( retyper_ctx, CppCall (FuncInternal (retypedObj, "get_length", "->"), []), exprType ) | TCppInterface _, _ | TCppDynamic, _ -> - ( retyped_ctx, + ( retyper_ctx, CppDynamicField (retypedObj, member.cf_name), TCppVariant ) | TCppObjC _, _ -> - ( retyped_ctx, + ( retyper_ctx, CppVar (VarInstance ( retypedObj, member, tcpp_to_string clazzType, "." )), exprType ) | _ -> @@ -536,11 +536,11 @@ let expression ctx request_type function_args function_type expression_tree forI else "->" in - ( retyped_ctx, + ( 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 - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInterface (retypedObj, clazz, member), funcReturn), exprType ) else @@ -570,15 +570,15 @@ let expression ctx request_type function_args function_type expression_tree forI in match retypedObj.cppexpr with | CppThis ThisReal -> - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncThis (member, retypedObj.cpptype), funcReturn), exprType ) | CppSuper this -> - ( retyped_ctx, + ( retyper_ctx, CppFunction ( FuncSuper (this, retypedObj.cpptype, member), funcReturn ), exprType ) | _ -> - ( retyped_ctx, + ( retyper_ctx, CppFunction ( FuncInstance ( retypedObj, @@ -589,102 +589,102 @@ let expression ctx request_type function_args function_type expression_tree forI | FStatic (_, ({ cf_name = "nativeFromStaticFunction" } as member)) -> let funcReturn = cpp_member_return_type member in let exprType = cpp_type_of member.cf_type in - (retyped_ctx, CppFunction (FuncFromStaticFunction, funcReturn), exprType) + (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 - (retyped_ctx, CppVar (VarStatic (clazz, objC, member)), exprType) + (retyper_ctx, CppVar (VarStatic (clazz, objC, member)), exprType) else - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncStatic (clazz, objC, member), funcReturn), exprType ) | FClosure (None, field) | FAnon field -> - let retyped_ctx, obj = retype retyped_ctx TCppDynamic obj in + let retyper_ctx, obj = retype retyper_ctx TCppDynamic obj in let fieldName = field.cf_name in if obj.cpptype = TCppGlobal then - (retyped_ctx, CppExtern (fieldName, true), cpp_type_of expr.etype) - else if obj.cpptype = TCppNull then (retyped_ctx, CppNullAccess, TCppDynamic) + (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 - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInternal (obj, fieldName, "."), cppType), cppType ) else - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInternal (obj, fieldName, "->"), cppType), cppType ) - else (retyped_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) + else (retyper_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) | FDynamic fieldName -> - let retyped_ctx, obj = retype retyped_ctx TCppDynamic obj in - if obj.cpptype = TCppNull then (retyped_ctx, 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 - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInternal (obj, "cca", "."), TCppScalar "int"), TCppDynamic ) else if fieldName = "__s" && obj.cpptype = TCppString then - ( retyped_ctx, + ( retyper_ctx, CppVar (VarInternal (obj, ".", "utf8_str()")), TCppRawPointer ("const ", TCppScalar "char") ) else if fieldName = "__Index" then - (retyped_ctx, 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 - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInternal (obj, fieldName, "."), cppType), cppType ) else - ( retyped_ctx, + ( retyper_ctx, CppFunction (FuncInternal (obj, fieldName, "->"), cppType), cppType ) else if obj.cpptype = TCppGlobal then - (retyped_ctx, 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, _) -> - ( retyped_ctx, + ( retyper_ctx, CppExtern ( join_class_path_remap path "::" ^ "_obj::" ^ fieldName, true ), cpp_type_of expr.etype ) | _ -> - ( retyped_ctx, + ( retyper_ctx, CppVar (VarInternal (obj, "->", fieldName)), cpp_type_of expr.etype ) - else (retyped_ctx, CppDynamicField (obj, fieldName), TCppVariant) + else (retyper_ctx, CppDynamicField (obj, fieldName), TCppVariant) | FEnum (enum, enum_field) -> - (retyped_ctx, CppEnumField (enum, enum_field), TCppEnum enum)) + (retyper_ctx, CppEnumField (enum, enum_field), TCppEnum enum)) | TCall ({ eexpr = TIdent "__cpp__" }, arg_list) -> - let retyped_ctx, cppExpr = + let retyper_ctx, cppExpr = match arg_list with - | [ { eexpr = TConst (TString code) } ] -> retyped_ctx, CppCode (code, []) + | [ { 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 retyped_ctx, retypedArgs = List.fold_left folder (retyped_ctx, []) remaining in - retyped_ctx, CppCode (code, List.rev retypedArgs) + 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 - (retyped_ctx, cppExpr, TCppCode (cpp_type_of expr.etype)) + (retyper_ctx, cppExpr, TCppCode (cpp_type_of expr.etype)) | TCall (func, args) -> ( - let retyped_ctx, retypedFunc = retype retyped_ctx TCppUnchanged func in + let retyper_ctx, retypedFunc = retype retyper_ctx TCppUnchanged func in match retypedFunc.cpptype with - | TCppNull -> (retyped_ctx, CppNullAccess, TCppDynamic) + | TCppNull -> (retyper_ctx, CppNullAccess, TCppDynamic) | TCppFunction (argTypes, retType, _) -> - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args argTypes in - (retyped_ctx, 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args argTypes in - (retyped_ctx, 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 arg_types = List.map (fun _ -> TCppDynamic) args in - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in match retypedArgs with | [ { @@ -693,7 +693,7 @@ let expression ctx request_type function_args function_type expression_tree forI (FuncStatic (clazz, false, member), funcReturn); }; ] -> - (retyped_ctx, CppFunctionAddress (clazz, member), funcReturn) + (retyper_ctx, CppFunctionAddress (clazz, member), funcReturn) | _ -> abort "cpp.Function.fromStaticFunction must be called on \ @@ -701,53 +701,53 @@ let expression ctx request_type function_args function_type expression_tree forI expr.epos) | CppEnumIndex _ -> (* Not actually a TCall...*) - (retyped_ctx, retypedFunc.cppexpr, retypedFunc.cpptype) + (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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - ( retyped_ctx, + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - ( retyped_ctx, + 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 retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in let rawType = match arg.cpptype with TCppReference x -> x | x -> x in - (retyped_ctx, CppAddressOf arg, TCppRawPointer ("", rawType)) + (retyper_ctx, CppAddressOf arg, TCppRawPointer ("", rawType)) | CppFunction (FuncStatic (obj, false, member), _) when member.cf_name = "::hx::StarOf" -> - let retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in let rawType = match arg.cpptype with TCppReference x -> x | x -> x in - (retyped_ctx, CppAddressOf arg, TCppStar (rawType, false)) + (retyper_ctx, CppAddressOf arg, TCppStar (rawType, false)) | CppFunction (FuncStatic (obj, false, member), _) when member.cf_name = "::hx::Dereference" -> - let retyped_ctx, arg = retype retyped_ctx TCppUnchanged (List.hd args) in + let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in let rawType = match arg.cpptype with TCppStar (x, _) -> x | x -> x in - (retyped_ctx, CppDereference arg, TCppReference rawType) + (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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types 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 _ -> - (retyped_ctx, CppCall (FuncNew return_type, retypedArgs), return_type) + (retyper_ctx, CppCall (FuncNew return_type, retypedArgs), return_type) | _ -> - ( retyped_ctx, CppCall (FuncNew TCppDynamicArray, 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in match retypedArgs with | { cppexpr = CppClassOf (path, native) } :: rest -> - ( retyped_ctx, CppCall (FuncTemplate (obj, member, path, native), rest), returnType ) + ( retyper_ctx, CppCall (FuncTemplate (obj, member, path, native), rest), returnType ) | _ -> abort "First parameter of template function must be a Class" @@ -755,7 +755,7 @@ let expression ctx request_type function_args function_type expression_tree forI | CppFunction (FuncInstance (obj, InstPtr, member), _) when is_map_get_call obj member -> let arg_types = List.map (fun _ -> TCppDynamic) args in - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let fname, cppType = match return_type with | TCppVoid | TCppScalar "bool" -> @@ -783,11 +783,11 @@ let expression ctx request_type function_args function_type expression_tree forI CppCastStatic(call, cppType), cppType end else *) - (retyped_ctx, CppCall (func, retypedArgs), cppType) + (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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let fname = match retypedArgs with | [ _; { cpptype = TCppScalar "bool" } ] -> "setBool" @@ -799,16 +799,16 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> "set" in let func = FuncInstance (obj, InstPtr, { member with cf_name = fname }) in - (retyped_ctx, CppCall (func, retypedArgs), cppType) + (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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let call = mk_cppexpr (CppCall (func, retypedArgs)) returnType in - (retyped_ctx, CppCastStatic (call, cppType), cppType) + (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 @@ -829,8 +829,8 @@ let expression ctx request_type function_args function_type expression_tree forI (fun (_, opt, t) -> cpp_tfun_arg_type_of opt t) real_types in - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - (retyped_ctx, CppCall (func, retypedArgs), return_type) + 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 ) -> @@ -840,50 +840,50 @@ let expression ctx request_type function_args function_type expression_tree forI arg_types in (* retype args specifically (not just CppDynamic) *) - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - (retyped_ctx, CppCall (func, retypedArgs), returnType) + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - (retyped_ctx, CppCall (func, retypedArgs), returnType) + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - ( retyped_ctx, CppCall (FuncEnumConstruct (enum, field), retypedArgs), cppType ) + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - ( retyped_ctx, CppCall (FuncSuperConstruct retypedFunc.cpptype, retypedArgs), TCppVoid ) + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in + let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in (* Special function calls *) match (expr.cpptype, name) with | TCppGlobal, _ -> - (retyped_ctx, CppCall (FuncExtern (name, true), retypedArgs), cppType) + (retyper_ctx, CppCall (FuncExtern (name, true), retypedArgs), cppType) | TCppString, _ -> - ( retyped_ctx, + ( retyper_ctx, CppCall (FuncInternal (expr, name, "."), retypedArgs), cppType ) | _, "__Tag" -> - ( retyped_ctx, + ( retyper_ctx, CppCall (FuncInternal (expr, "_hx_getTag", "->"), retypedArgs), cppType ) | _, name when is_internal_member name -> - ( retyped_ctx, CppCall (FuncInternal (expr, name, "->"), retypedArgs), cppType ) + ( retyper_ctx, CppCall (FuncInternal (expr, name, "->"), retypedArgs), cppType ) | _ -> (* not special *) - ( retyped_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), TCppDynamic )) + ( retyper_ctx, CppCall (FuncExpression retypedFunc, retypedArgs), TCppDynamic )) | CppExtern (name, isGlobal) -> let arg_types = List.map (fun _ -> TCppUnchanged) args in - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - (retyped_ctx, CppCall (FuncExtern (name, isGlobal), retypedArgs), cppType) + 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 retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types in - ( retyped_ctx, + 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) -> @@ -896,18 +896,18 @@ let expression ctx request_type function_args function_type expression_tree forI | Some (_, constructor, _) -> constructor.cf_type in let arg_types, _ = cpp_function_type_of_args_ret constructor_type in - let retyped_ctx, retypedArgs = retype_function_args retyped_ctx args arg_types 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 = - retyped_ctx.gc_stack || match created_type with + retyper_ctx.gc_stack || match created_type with | TCppInst (t, _) -> not (is_native_class t) | _ -> false in - ({ retyped_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) + ({ retyper_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> (* TODO - this_dynamic ? *) let new_ctx = { - retyped_ctx with + retyper_ctx with declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> StringMap.of_list; undeclared = StringMap.empty; this_real = ThisFake; @@ -919,7 +919,7 @@ let expression ctx request_type function_args function_type expression_tree forI let result = { close_expr = cppExpr; - close_id = retyped_ctx.closure_id; + close_id = retyper_ctx.closure_id; close_undeclared = new_ctx.undeclared; close_type = new_ctx.function_return_type; close_args = func.tf_args; @@ -927,7 +927,7 @@ let expression ctx request_type function_args function_type expression_tree forI } in let folder acc (name, tvar) = - if not (StringMap.mem name retyped_ctx.declarations) then + if not (StringMap.mem name retyper_ctx.declarations) then StringMap.add name tvar acc else acc @@ -935,65 +935,65 @@ let expression ctx request_type function_args function_type expression_tree forI let new_undeclared = List.fold_left folder - retyped_ctx.undeclared + retyper_ctx.undeclared (StringMap.bindings new_ctx.undeclared) in - let retyped_ctx = { - retyped_ctx with - closure_id = retyped_ctx.closure_id + 1; - closures = result :: retyped_ctx.closures; + 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 retyped_ctx.this_real else retyped_ctx.uses_this; + uses_this = if new_ctx.uses_this != None then Some retyper_ctx.this_real else retyper_ctx.uses_this; } in - (retyped_ctx, CppClosure result, TCppDynamic) + (retyper_ctx, CppClosure result, TCppDynamic) | TArray (e1, e2) -> - let retyped_ctx, arrayExpr, elemType = + let retyper_ctx, arrayExpr, elemType = match cpp_is_native_array_access (cpp_type_of e1.etype) with | true -> - let retyped_ctx, retypedObj = retype retyped_ctx TCppUnchanged e1 in - let retyped_ctx, retypedIdx = retype retyped_ctx (TCppScalar "int") e2 in - ( retyped_ctx, + 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 retyped_ctx, retypedObj = retype retyped_ctx TCppDynamic e1 in - let retyped_ctx, retypedIdx = retype retyped_ctx (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 -> - ( retyped_ctx, + ( retyper_ctx, CppArray (ArrayTyped (retypedObj, retypedIdx, scalar)), scalar ) | TCppPointer (_, elem) -> - (retyped_ctx, CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) + (retyper_ctx, CppArray (ArrayPointer (retypedObj, retypedIdx)), elem) | TCppRawPointer (_, elem) -> - (retyped_ctx, CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) + (retyper_ctx, CppArray (ArrayRawPointer (retypedObj, retypedIdx)), elem) | TCppObjectArray TCppDynamic -> - ( retyped_ctx, + ( retyper_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), TCppDynamic ) | TCppObjectArray elem -> - (retyped_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) + (retyper_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) | TCppInst (({ cl_array_access = Some _ } as klass), _) -> - ( retyped_ctx, CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), + ( retyper_ctx, CppArray (ArrayImplements (klass, retypedObj, retypedIdx)), cpp_type_of expr.etype ) | TCppDynamicArray -> - ( retyped_ctx, + ( retyper_ctx, CppArray (ArrayVirtual (retypedObj, retypedIdx)), TCppDynamic ) | _ -> - ( retyped_ctx, + ( retyper_ctx, CppArray (ArrayDynamic (retypedObj, retypedIdx)), TCppDynamic )) in let returnType = cpp_type_of expr.etype in if cpp_can_static_cast elemType returnType then - ( retyped_ctx, + ( retyper_ctx, CppCastStatic (mk_cppexpr arrayExpr returnType, returnType), returnType ) else - (retyped_ctx, arrayExpr, elemType) + (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 *) @@ -1004,22 +1004,22 @@ let expression ctx request_type function_args function_type expression_tree forI ([ "cpp" ], "Int64") | _ -> t_path module_type in - (retyped_ctx, 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 retyped_ctx, binOpType = + let retyper_ctx, binOpType = match op with - | OpDiv -> retyped_ctx, TCppScalar "Float" - | OpBoolAnd | OpBoolOr -> retyped_ctx, TCppScalar "bool" - | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> retyped_ctx, TCppScalar "int" + | OpDiv -> retyper_ctx, TCppScalar "Float" + | OpBoolAnd | OpBoolOr -> retyper_ctx, TCppScalar "bool" + | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> retyper_ctx, TCppScalar "int" | OpAssign -> - let retyped_ctx, retyped_expr = (retype retyped_ctx TCppUnchanged left) in - (retyped_ctx, retyped_expr.cpptype) + let retyper_ctx, retyped_expr = (retype retyper_ctx TCppUnchanged left) in + (retyper_ctx, retyped_expr.cpptype) | OpMult | OpSub -> - retyped_ctx, cpp_type_of expr.etype - | _ -> retyped_ctx, TCppUnchanged + retyper_ctx, cpp_type_of expr.etype + | _ -> retyper_ctx, TCppUnchanged in - let retyped_ctx, e1 = retype retyped_ctx binOpType left in - let retyped_ctx, e2 = retype retyped_ctx 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 @@ -1032,47 +1032,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 retyped_ctx, reference = + let retyper_ctx, reference = match op with | OpAssign -> let lvalue, gc = to_lvalue e1 in - let new_ctx = if gc then { retyped_ctx with gc_stack = true } else retyped_ctx in + 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 - let new_ctx = if gc then { retyped_ctx with gc_stack = true } else retyped_ctx in + 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 -> retyped_ctx, CppBool true - | OpGte when e1_null && e2_null -> retyped_ctx, CppBool true - | OpLte when e1_null && e2_null -> retyped_ctx, CppBool true - | OpNotEq when e1_null && e2_null -> retyped_ctx, CppBool false - | _ when e1_null && e2_null -> retyped_ctx, CppBool false - | OpEq when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) - | OpGte when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) - | OpLte when e1_null -> retyped_ctx, CppNullCompare ("IsNull", e2) - | OpNotEq when e1_null -> retyped_ctx, CppNullCompare ("IsNotNull", e2) - | OpEq when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) - | OpGte when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) - | OpLte when e2_null -> retyped_ctx, CppNullCompare ("IsNull", e1) - | OpNotEq when e2_null -> retyped_ctx, CppNullCompare ("IsNotNull", e1) - | OpEq when instance -> retyped_ctx, CppCompare ("IsInstanceEq", e1, e2, op) - | OpNotEq when instance -> retyped_ctx, CppCompare ("IsInstanceNotEq", e1, e2, op) - | OpEq when pointer -> retyped_ctx, CppCompare ("IsPointerEq", e1, e2, op) - | OpNotEq when pointer -> retyped_ctx, CppCompare ("IsPointerNotEq", e1, e2, op) - | OpEq when complex -> retyped_ctx, CppCompare ("IsEq", e1, e2, op) - | OpNotEq when complex -> retyped_ctx, CppCompare ("IsNotEq", e1, e2, op) - | OpGte when complex -> retyped_ctx, CppCompare ("IsGreaterEq", e1, e2, op) - | OpLte when complex -> retyped_ctx, CppCompare ("IsLessEq", e1, e2, op) - | OpGt when complex -> retyped_ctx, CppCompare ("IsGreater", e1, e2, op) - | OpLt when complex -> retyped_ctx, CppCompare ("IsLess", e1, e2, op) - | _ -> retyped_ctx, CppBinop (op, e1, 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, _ -> - (retyped_ctx, reference, TCppVariant) + (retyper_ctx, reference, TCppVariant) | _, _, _ -> - (retyped_ctx, reference, cpp_type_of expr.etype)) + (retyper_ctx, reference, cpp_type_of expr.etype)) | TUnop (op, pre, e1) -> let targetType = match op with @@ -1081,39 +1081,39 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> cpp_type_of e1.etype in - let retyped_ctx, e1 = retype retyped_ctx targetType e1 in - let retyped_ctx, 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 - let new_ctx = if gc then { retyped_ctx with gc_stack = true } else retyped_ctx in + 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 - let new_ctx = if gc then { retyped_ctx with gc_stack = true } else retyped_ctx in + let new_ctx = if gc then { retyper_ctx with gc_stack = true } else retyper_ctx in new_ctx, CppCrement (CppDecrement, pre, lvalue) - | Neg -> retyped_ctx, CppUnop (CppNeg, e1) - | Not -> retyped_ctx, CppUnop (CppNot, e1) - | NegBits -> retyped_ctx, CppUnop (CppNegBits, e1) + | 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 - (retyped_ctx, reference, cpp_type_of expr.etype) + (retyper_ctx, reference, cpp_type_of expr.etype) | TFor (v, init, block) -> - let retyped_ctx = { retyped_ctx with declarations = StringMap.add v.v_name () retyped_ctx.declarations } in - let retyped_ctx, init = retype retyped_ctx (cpp_type_of v.v_type) init in - let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block block) in - let retyped_ctx = { retyped_ctx with declarations = StringMap.remove v.v_name retyped_ctx.declarations } in - (retyped_ctx, 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 retyped_ctx, condition = retype retyped_ctx (TCppScalar "bool") e1 in - let retyped_ctx, close = begin_loop retyped_ctx in - let retyped_ctx, block = retype retyped_ctx TCppVoid (mk_block e2) in - let retyped_ctx, id = close retyped_ctx in - (retyped_ctx, CppWhile (condition, block, flag, id), 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 el_types = List.map (fun _ -> TCppDynamic) el in - let retyped_ctx, retypedEls = retype_function_args retyped_ctx el el_types in - (retyped_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) + 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 -> if return_type <> TCppVoid && not forCppia then print_endline @@ -1121,12 +1121,12 @@ let expression ctx request_type function_args function_type expression_tree forI ^ string_of_int (Lexer.get_error_line expr.epos)); let remaining = ref (List.length expr_list) in - let new_ctx = { retyped_ctx with closures = []; injection = false } in + let new_ctx = { retyper_ctx with closures = []; injection = false } in let new_ctx, cppExprs = List.fold_left (fun (cur_ctx, exprs) expr -> let targetType = - if retyped_ctx.injection && !remaining = 1 then cpp_type_of expr.etype + if retyper_ctx.injection && !remaining = 1 then cpp_type_of expr.etype else TCppVoid in decr remaining; @@ -1139,7 +1139,7 @@ let expression ctx request_type function_args function_type expression_tree forI (* Add back any undeclared variables *) (* Needed for tracking variables captured by variables *) let folder acc (name, tvar) = - if not (StringMap.mem name retyped_ctx.declarations) then + if not (StringMap.mem name retyper_ctx.declarations) then StringMap.add name tvar acc else acc @@ -1147,15 +1147,15 @@ let expression ctx request_type function_args function_type expression_tree forI let new_undeclared = List.fold_left folder - retyped_ctx.undeclared + retyper_ctx.undeclared (StringMap.bindings new_ctx.undeclared) in ( { new_ctx with - declarations = retyped_ctx.declarations; + declarations = retyper_ctx.declarations; undeclared = new_undeclared; - closures = retyped_ctx.closures }, + closures = retyper_ctx.closures }, CppBlock (List.rev cppExprs, List.rev new_ctx.closures, new_ctx.gc_stack), TCppVoid ) @@ -1166,40 +1166,40 @@ let expression ctx request_type function_args function_type expression_tree forI (("className", _, _), { eexpr = TConst (TString class_name) }); (("methodName", _, _), { eexpr = TConst (TString meth) }); ] -> - (retyped_ctx, CppPosition (file, line, class_name, meth), TCppDynamic) + (retyper_ctx, CppPosition (file, line, class_name, meth), TCppDynamic) | TObjectDecl el -> ( let el_exprs = List.map (fun ((_, _, _), e) -> e) el in let el_names = List.map (fun ((v, _, _), _) -> v) el in - let retyped_ctx, retyped_els = - List.map (fun _ -> TCppDynamic) el |> retype_function_args retyped_ctx el_exprs + 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 -> (retyped_ctx, CppObjectDecl (joined, false), TCppVoid) - | _ -> (retyped_ctx, CppObjectDecl (joined, 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 retyped_ctx, init = + let retyper_ctx, init = match eo with - | None -> retyped_ctx, None - | Some e -> retype retyped_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - let retyped_ctx = { retyped_ctx with declarations = StringMap.add v.v_name () retyped_ctx.declarations } in - (retyped_ctx, 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 retyped_ctx, ec = retype retyped_ctx (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 retyped_ctx, e1 = retype retyped_ctx return_type (blockify e1) in - let retyped_ctx, e2 = + let retyper_ctx, e1 = retype retyper_ctx return_type (blockify e1) in + let retyper_ctx, e2 = match e2 with - | None -> retyped_ctx, None - | Some e -> retype retyped_ctx return_type (blockify e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) + | None -> retyper_ctx, None + | Some e -> retype retyper_ctx return_type (blockify e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - ( retyped_ctx, + ( retyper_ctx, CppIf (ec, e1, e2), if return_type = TCppVoid then TCppVoid else cpp_type_of expr.etype ) @@ -1214,14 +1214,14 @@ 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 retyped_ctx, condition = retype retyped_ctx conditionType condition in - let retyped_ctx, cppDef = + let retyper_ctx, condition = retype retyper_ctx conditionType condition in + let retyper_ctx, cppDef = match def with - | None -> retyped_ctx, None - | Some e -> retype retyped_ctx TCppVoid (mk_block e) |> (fun (new_ctx, expr) -> new_ctx, Some expr) + | 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 retyped_ctx, cases = + 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 @@ -1232,28 +1232,28 @@ let expression ctx request_type function_args function_type expression_tree forI el in new_ctx, (List.rev blocks, cppBlock) :: acc) - (retyped_ctx, []) + (retyper_ctx, []) cases in - (retyped_ctx, CppSwitch (condition, conditionType, List.rev 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 retyped_ctx, cases = + 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) - (retyped_ctx, []) + (retyper_ctx, []) cases in - (retyped_ctx, CppIntSwitch (condition, List.rev cases, cppDef), TCppVoid) + (retyper_ctx, CppIntSwitch (condition, List.rev cases, cppDef), TCppVoid) with Not_found -> - let retyped_ctx, label = alloc_file_id retyped_ctx in + let retyper_ctx, label = alloc_file_id retyper_ctx in (* do something better maybe ... *) - let retyped_ctx, cases = + 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 @@ -1271,63 +1271,63 @@ let expression ctx request_type function_args function_type expression_tree forI (new_ctx, []) el in new_ctx, (List.rev blocks, cppBlock) :: acc) - (retyped_ctx, []) + (retyper_ctx, []) cases in - ( retyped_ctx, + ( 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 retyped_ctx, cppBlock = retype retyped_ctx TCppVoid try_block in - let retyped_ctx, cppCatches = + let retyper_ctx, cppBlock = retype retyper_ctx TCppVoid try_block in + let retyper_ctx, cppCatches = List.fold_left - (fun (retyped_ctx, acc) (tvar, catch_block) -> - let retyped_ctx = { retyped_ctx with declarations = StringMap.add tvar.v_name () retyped_ctx.declarations } in - let retyped_ctx, cppCatchBlock = retype retyped_ctx TCppVoid catch_block in - let retyped_ctx = { retyped_ctx with declarations = StringMap.remove tvar.v_name retyped_ctx.declarations } in - retyped_ctx, (tvar, cppCatchBlock) :: acc) - (retyped_ctx, []) + (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 - (retyped_ctx, CppTry (cppBlock, List.rev cppCatches), TCppVoid) + (retyper_ctx, CppTry (cppBlock, List.rev cppCatches), TCppVoid) | TReturn eo -> - let retyped_ctx, expr = match eo with - | None -> retyped_ctx, None - | Some e -> retype retyped_ctx retyped_ctx.function_return_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - ( retyped_ctx, + 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 retyped_ctx, baseCpp = retype retyped_ctx 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 - (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with - | TCppObjC k -> (retyped_ctx, CppCastObjC (baseCpp, k), return_type) + | TCppObjC k -> (retyper_ctx, CppCastObjC (baseCpp, k), return_type) | TCppPointer (_, _) | TCppRawPointer (_, _) | TCppStar _ | TCppInst _ -> - (retyped_ctx, CppCast (baseCpp, return_type), return_type) - | TCppString -> (retyped_ctx, 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 -> - (retyped_ctx, CppCast (baseCpp, t), t) - | TCppNativePointer klass -> (retyped_ctx, CppCastNative baseCpp, return_type) + (retyper_ctx, CppCast (baseCpp, t), t) + | TCppNativePointer klass -> (retyper_ctx, CppCastNative baseCpp, return_type) | TCppObjCBlock (args, ret) -> - (retyped_ctx, CppCastObjCBlock (baseCpp, args, ret), return_type) - | TCppProtocol p -> (retyped_ctx, 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 -> - (retyped_ctx, CppCast (baseCpp, TCppDynamic), TCppDynamic) - | _ -> (retyped_ctx, 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 retyped_ctx, baseCpp = retype retyped_ctx (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 @@ -1339,75 +1339,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 - (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with | TCppNativePointer klass -> - ( retyped_ctx, CppCastNative baseCpp, return_type) + ( retyper_ctx, CppCastNative baseCpp, return_type) | TCppVoid -> - (retyped_ctx, CppTCast (baseCpp, cpp_type_of expr.etype), return_type) + (retyper_ctx, CppTCast (baseCpp, cpp_type_of expr.etype), return_type) | TCppDynamic -> - (retyped_ctx, baseCpp.cppexpr, baseCpp.cpptype) + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype) | _ -> - (retyped_ctx, CppTCast (baseCpp, return_type), return_type)) + (retyper_ctx, CppTCast (baseCpp, return_type), return_type)) in let cppExpr = mk_cppexpr retypedExpr retypedType in (* Autocast rules... *) if return_type = TCppVoid then - retyped_ctx, mk_cppexpr retypedExpr TCppVoid + retyper_ctx, mk_cppexpr retypedExpr TCppVoid else if return_type = TCppVarArg then match cpp_variant_type_of cppExpr.cpptype with - | TCppVoidStar | TCppScalar _ -> retyped_ctx, cppExpr + | TCppVoidStar | TCppScalar _ -> retyper_ctx, cppExpr | TCppString -> - retyped_ctx, mk_cppexpr + retyper_ctx, mk_cppexpr (CppVar (VarInternal (cppExpr, ".", "raw_ptr()"))) (TCppPointer ("ConstPointer", TCppScalar "char")) - | TCppDynamic -> retyped_ctx, mk_cppexpr (CppCastNative cppExpr) TCppVoidStar + | TCppDynamic -> retyper_ctx, mk_cppexpr (CppCastNative cppExpr) TCppVoidStar | _ -> let toDynamic = mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic in - retyped_ctx, 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 -> retyped_ctx, 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 - retyped_ctx, 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 _ -> - retyped_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type - | TCppObjC k -> retyped_ctx, 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) -> - retyped_ctx, mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type + retyper_ctx, mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type | TCppScalar scalar -> - retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type | TCppString -> - retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type | TCppInterface _ when cppExpr.cpptype = TCppVariant -> - retyped_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type + retyper_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type | TCppDynamic when cppExpr.cpptype = TCppVariant -> - retyped_ctx, 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 - retyped_ctx, mk_cppexpr + retyper_ctx, mk_cppexpr (CppCast (ptrCast, TCppStar (t, const))) (TCppStar (t, const)) - | _ -> retyped_ctx, cppExpr + | _ -> retyper_ctx, cppExpr else match (cppExpr.cpptype, return_type) with - | _, TCppUnchanged -> retyped_ctx, 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 @@ -1438,56 +1438,56 @@ let expression ctx request_type function_args function_type expression_tree forI *) | TCppAutoCast, _ | TCppObjC _, TCppDynamic | TCppObjCBlock _, TCppDynamic -> - retyped_ctx, 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 _ -> retyped_ctx, cppExpr - | TCppReference TCppDynamic, t -> retyped_ctx, mk_cppexpr retypedExpr (TCppReference t) - | TCppStar (TCppDynamic, _), TCppStar (_, _) -> retyped_ctx, 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 -> - retyped_ctx, 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 - retyped_ctx, 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 _ -> - retyped_ctx, 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 -> - retyped_ctx, mk_cppexpr (CppNewNative cppExpr) return_type + retyper_ctx, mk_cppexpr (CppNewNative cppExpr) return_type | TCppInst _, TCppStar (p, const) | TCppStruct _, TCppStar (p, const) -> - retyped_ctx, mk_cppexpr (CppAddressOf cppExpr) return_type - | TCppObjectPtr, TCppObjectPtr -> retyped_ctx, cppExpr + retyper_ctx, mk_cppexpr (CppAddressOf cppExpr) return_type + | TCppObjectPtr, TCppObjectPtr -> retyper_ctx, cppExpr | TCppObjectPtr, _ -> - retyped_ctx, mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic - | TCppProtocol _, TCppProtocol _ -> retyped_ctx, cppExpr + retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic + | TCppProtocol _, TCppProtocol _ -> retyper_ctx, cppExpr | t, TCppProtocol protocol -> - retyped_ctx, 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 - retyped_ctx, mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic + retyper_ctx, mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic | _, TCppObjectPtr -> - retyped_ctx, mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr + retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr | TCppDynamicArray, TCppScalarArray _ | TCppDynamicArray, TCppObjectArray _ | TCppScalarArray _, TCppDynamicArray | TCppObjectArray _, TCppDynamicArray when forCppia -> - retyped_ctx, 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 -> - retyped_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type - | _ -> retyped_ctx, cppExpr + retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type + | _ -> retyper_ctx, cppExpr in retype initial_ctx request_type expression_tree |> snd From 0b41462aaa20d8d5cf57b5f4cccc92a4f597609c Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 29 Nov 2024 18:05:07 +0000 Subject: [PATCH 96/97] move remaining counter into the fold --- src/generators/cpp/cppRetyper.ml | 17 ++++++++--------- src/generators/cpp/gen/cppGen.ml | 1 + 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 1d655af940c..a0a2a4e30f9 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -1120,19 +1120,18 @@ let expression ctx request_type function_args function_type expression_tree forI ("Value from a block not handled " ^ expr.epos.pfile ^ " " ^ string_of_int (Lexer.get_error_line expr.epos)); - let remaining = ref (List.length expr_list) in let new_ctx = { retyper_ctx with closures = []; injection = false } in - let new_ctx, cppExprs = + let new_ctx, cppExprs, _ = List.fold_left - (fun (cur_ctx, exprs) expr -> + (fun (cur_ctx, exprs, remaining) expr -> let targetType = - if retyper_ctx.injection && !remaining = 1 then cpp_type_of expr.etype - else TCppVoid - in - decr remaining; + 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) - (new_ctx, []) + new_ctx, result :: exprs, remaining - 1) + (new_ctx, [], List.length expr_list) expr_list in diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 8cfb76d418d..fae5d573359 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -1461,6 +1461,7 @@ 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 = StringMap.bindings closure.close_undeclared |> List.length in let size = string_of_int argc in From 9a115268f2e690c3de2f95ffc2f4887c0517f04f Mon Sep 17 00:00:00 2001 From: Aidan Lee Date: Fri, 29 Nov 2024 20:24:44 +0000 Subject: [PATCH 97/97] shared string_map_of_list function --- src/generators/cpp/cppAstTools.ml | 2 ++ src/generators/cpp/cppRetyper.ml | 4 ++-- src/generators/cpp/gen/cppGen.ml | 4 +--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index a1101f6d7c4..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 "::" diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 750c2e9fd5c..d48d9d093f7 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -201,7 +201,7 @@ let expression ctx request_type function_args function_type expression_tree forI closure_id = 0; injection = forInjection; undeclared = StringMap.empty; - declarations = function_args |> List.map (fun a -> a.v_name, ()) |> StringMap.of_list |> StringMap.add "__trace" (); (* '__trace' is at the top-level *) + 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; @@ -907,7 +907,7 @@ let expression ctx request_type function_args function_type expression_tree forI let new_ctx = { retyper_ctx with - declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> StringMap.of_list; + declarations = func.tf_args |> List.map (fun (a, _) -> a.v_name, ()) |> string_map_of_list; undeclared = StringMap.empty; this_real = ThisFake; uses_this = None; diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index c0c160064e8..4d382805c6d 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -424,12 +424,10 @@ let gen_gc_name class_path = const_char_star class_name_text let needed_interface_functions implemented_instance_fields native_implementations = - let of_list bs = List.fold_left (fun m (k, v) -> StringMap.add k v m) StringMap.empty bs in - let have = implemented_instance_fields |> List.map (fun (func) -> (func.tcf_name, ())) - |> of_list + |> string_map_of_list in let func_folder (have, acc) func = if StringMap.mem func.iff_name have then