diff --git a/src-json/meta.json b/src-json/meta.json index 4e46889ada4..3acd7ce3b80 100644 --- a/src-json/meta.json +++ b/src-json/meta.json @@ -1005,6 +1005,33 @@ "platforms": ["cpp"], "targets": ["TClass"] }, + { + "name": "NativeArrayAccess", + "metadata": ":nativeArrayAccess", + "doc": "When used on an extern class which implements haxe.ArrayAccess native array access syntax will be generated", + "platforms": ["cpp"] + }, + { + "name": "CppValueType", + "metadata": ":cpp.ValueType", + "doc": "Indicates that the externed type should be treated as a value type", + "platforms": ["cpp"], + "targets": [ "TClass", "TAbstract" ] + }, + { + "name": "CppPointerType", + "metadata": ":cpp.PointerType", + "doc": "Indicates that the externed type should be treated as a pointer", + "platforms": ["cpp"], + "targets": [ "TClass" ] + }, + { + "name": "CppManagedType", + "metadata": ":cpp.ManagedType", + "doc": "Indicates that the externed type is a sub class of ::hx::Object", + "platforms": ["cpp"], + "targets": ["TClass"] + }, { "name": "StructInit", "metadata": ":structInit", @@ -1124,11 +1151,5 @@ "metadata": ":wrappedException", "doc": "Internally used for exceptions wrapping in `throw` expressions.", "internal": true - }, - { - "name": "NativeArrayAccess", - "metadata": ":nativeArrayAccess", - "doc": "When used on an extern class which implements haxe.ArrayAccess native array access syntax will be generated", - "platforms": ["cpp"] } ] diff --git a/src/generators/cpp/cppAst.ml b/src/generators/cpp/cppAst.ml index f30a0bd0cfc..7e26a83c668 100644 --- a/src/generators/cpp/cppAst.ml +++ b/src/generators/cpp/cppAst.ml @@ -40,7 +40,17 @@ module InterfaceSlots = struct StringMap.find_opt name slots.hash end -type tcpp = +type marshal_type_state = + | Stack + | Promoted + | Reference + +and native_type = + | ValueClass of tclass * tcpp list + | ValueEnum of tabstract + | Pointer of tclass * tcpp list + +and tcpp = | TCppDynamic | TCppUnchanged | TCppObject @@ -58,6 +68,8 @@ type tcpp = | TCppRest of tcpp | TCppReference of tcpp | TCppStruct of tcpp + | TCppMarshalNativeType of native_type * marshal_type_state + | TCppMarshalManagedType of tclass * tcpp list | TCppStar of tcpp * bool | TCppVoidStar | TCppVarArg @@ -78,12 +90,19 @@ type tcpp = and tcppexpr = { cppexpr : tcpp_expr_expr; cpptype : tcpp; cpppos : pos } +and tcppvar = { + tcppv_type : tcpp; + tcppv_var : tvar; + tcppv_name : string; + tcppv_debug_name : string; +} + and tcpp_closure = { close_type : tcpp; - close_args : (tvar * texpr option) list; + close_args : (tcppvar * texpr option) list; close_expr : tcppexpr; close_id : int; - close_undeclared : tvar StringMap.t; + close_undeclared : tcppvar StringMap.t; close_this : tcppthis option; } @@ -92,8 +111,8 @@ and tcppunop = CppNeg | CppNegBits | CppNot and tcppthis = ThisReal | ThisFake | ThisDynamic and tcppvarloc = - | VarLocal of tvar - | VarClosure of tvar + | VarLocal of tcppvar + | VarClosure of tcppvar | VarThis of tclass_field * tcpp | VarInstance of tcppexpr * tclass_field * string * string | VarInterface of tcppexpr * tclass_field @@ -166,15 +185,15 @@ and tcpp_expr_expr = | CppPosition of string * int32 * string * string | CppArrayDecl of tcppexpr list | CppUnop of tcppunop * tcppexpr - | CppVarDecl of tvar * tcppexpr option + | CppVarDecl of tcppvar * tcppexpr option | CppBlock of tcppexpr list * tcpp_closure list * bool - | CppFor of tvar * tcppexpr * tcppexpr + | CppFor of tcppvar * tcppexpr * tcppexpr | CppIf of tcppexpr * tcppexpr * tcppexpr option | CppWhile of tcppexpr * tcppexpr * Ast.while_flag * int | CppIntSwitch of tcppexpr * (Int32.t list * tcppexpr) list * tcppexpr option | CppSwitch of tcppexpr * tcpp * (tcppexpr list * tcppexpr) list * tcppexpr option * int - | CppTry of tcppexpr * (tvar * tcppexpr) list + | CppTry of tcppexpr * (tcppvar * tcppexpr) list | CppBreak | CppContinue | CppClassOf of path * bool @@ -211,6 +230,8 @@ and tcpp_class_function = { tcf_field : tclass_field; tcf_name : string; tcf_func : tfunc; + tcf_args : (tcppvar * texpr option) list; + tcf_return : tcpp; tcf_is_virtual : bool; tcf_is_reflective : bool; @@ -239,6 +260,7 @@ and tcpp_class = { tcl_debug_level : int; tcl_super : tcpp_class option; tcl_container : tcpp_class_container option; + tcl_constructor : tcpp_class_function option; tcl_haxe_interfaces : tcpp_interface list; tcl_native_interfaces : tcpp_interface list; @@ -261,8 +283,8 @@ and tcpp_class = { and tcpp_interface_function = { iff_field : tclass_field; iff_name : string; - iff_args : (string * bool * t) list; - iff_return : t; + iff_args : tcpp_tfun_arg list; + iff_return : tcpp; iff_script_slot : int option; } @@ -279,9 +301,16 @@ and tcpp_interface = { if_scriptable : bool; } +and tcpp_tfun_arg = { + tfa_name : string; + tfa_type : tcpp; + tfa_optional : bool; +} + and tcpp_enum_field = { tef_field : tenum_field; tef_name : string; + tef_args : tcpp_tfun_arg list option; tef_hash : string; } diff --git a/src/generators/cpp/cppAstTools.ml b/src/generators/cpp/cppAstTools.ml index 705e9c33a54..5441ab145d5 100644 --- a/src/generators/cpp/cppAstTools.ml +++ b/src/generators/cpp/cppAstTools.ml @@ -1,6 +1,7 @@ open Ast open Type open Globals +open Error open CppAst open CppTypeUtils @@ -249,6 +250,16 @@ let keyword_remap name = "_hx_" ^ name | x -> x +let cpp_var_name_of var = + match get_meta_string var.v_meta Meta.Native with + | Some n -> n + | None -> keyword_remap var.v_name + +let cpp_var_debug_name_of v = + match get_meta_string v.v_meta Meta.RealPath with + | Some n -> n + | None -> v.v_name + let remap_class_path class_path = let path_remap with_keywords name = let len = String.length name in @@ -357,8 +368,11 @@ and tcpp_to_string_suffix suffix tcpp = | TCppUnchanged -> " ::Dynamic/*Unchanged*/" | TCppObject -> " ::Dynamic" | TCppObjectPtr -> " ::hx::Object *" - | TCppReference t -> tcpp_to_string t ^ " &" | TCppStruct t -> "cpp::Struct< " ^ tcpp_to_string t ^ " >" + | TCppReference (TCppMarshalNativeType (value_type, _)) -> Printf.sprintf "%s&" (get_native_marshalled_type value_type) + | TCppReference t -> tcpp_to_string t ^ " &" + | TCppStar (TCppMarshalNativeType (value_type, _), const) -> + Printf.sprintf "%s%s*" (if const then "const " else "") (get_native_marshalled_type value_type) | TCppStar (t, const) -> (if const then "const " else "") ^ tcpp_to_string t ^ " *" | TCppVoid -> "void" @@ -372,8 +386,12 @@ and tcpp_to_string_suffix suffix tcpp = | TCppString -> "::String" | TCppFastIterator it -> "::cpp::FastIterator" ^ suffix ^ "< " ^ tcpp_to_string it ^ " >" + | TCppPointer (ptrType, TCppMarshalNativeType (value_type, _)) -> + Printf.sprintf "::cpp::%s< %s >" ptrType (get_native_marshalled_type value_type) | TCppPointer (ptrType, valueType) -> "::cpp::" ^ ptrType ^ "< " ^ tcpp_to_string valueType ^ " >" + | TCppRawPointer (constName, TCppMarshalNativeType (value_type, _)) -> + Printf.sprintf "%s%s*" constName (get_native_marshalled_type value_type) | TCppRawPointer (constName, valueType) -> constName ^ tcpp_to_string valueType ^ "*" | TCppFunction (argTypes, retType, abi) -> @@ -411,6 +429,110 @@ and tcpp_to_string_suffix suffix tcpp = | TCppNull -> " ::Dynamic" | TCppCode _ -> "Code" + | TCppMarshalManagedType (cls, params) -> + let type_str, flags = build_type cls.cl_path cls.cl_pos params cls.cl_meta Meta.CppManagedType tcpp_to_string in + let standard_naming = List.exists (fun f -> f = "StandardNaming") flags in + let wrapped = + if suffix = "_obj" then + if standard_naming then + type_str ^ suffix + else + type_str + else + if standard_naming then + type_str + else + Printf.sprintf "::hx::ObjectPtr< %s >" type_str + in + wrapped + + | TCppMarshalNativeType (Pointer _ as value_type, Promoted) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::Boxed< %s* >" + | TCppMarshalNativeType (Pointer _ as value_type, Reference) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::PointerReference< %s >" + | TCppMarshalNativeType (Pointer _ as value_type, Stack) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::PointerType< %s >" + + | TCppMarshalNativeType ((ValueClass _ | ValueEnum _) as value_type, Promoted) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::Boxed< %s >" + | TCppMarshalNativeType ((ValueClass _ | ValueEnum _) as value_type, Reference) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::ValueReference< %s >" + | TCppMarshalNativeType ((ValueClass _ | ValueEnum _) as value_type, Stack) -> + get_native_marshalled_type value_type |> Printf.sprintf "::cpp::marshal::ValueType< %s >" + +and build_type path pos params meta target parameter_handler = + let get_meta_field field = + match Meta.get target meta with + | _, [ (EObjectDecl decls, _) ], _ -> + List.find_opt (fun ((n, _, _), _) -> n = field) decls + | _ -> + None + in + let typeParams = + match params with + | [] -> "" + | _ -> "< " ^ String.concat "," (List.map parameter_handler params) ^ " >" + in + let namespace_error pos = + abort "CPP0006: Namespace field must be an array declaration of string literals" pos + in + let flag_error pos = + abort "CPP0008: Flags field must be an array of identifiers" pos + in + let namespace = + match get_meta_field "namespace" with + | Some (_,( EArrayDecl ([]), _)) -> "" + | Some (_,( EArrayDecl (els), _)) -> + "::" ^ (els + |> List.filter_map (fun (e, pos) -> match e with | EConst (String (s, _)) -> Some s | _ -> namespace_error pos) + |> String.concat "::") + | Some ((_, pos, _), _) -> + namespace_error pos + | _ -> + "" + in + let t = match get_meta_field "type" with + | Some (_, (EConst (String (s, _)), _) ) -> + s ^ typeParams + | Some ((_, pos, _), _) -> + abort "CPP0007: Type field must be a string literal" pos + | _ -> + snd path ^ typeParams + in + let flags = match get_meta_field "flags" with + | Some (_, (EArrayDecl decls, _) ) -> + decls |> List.filter_map (fun (e, pos) -> match e with | EConst (Ident c) -> Some c | _ -> flag_error pos) + | Some ((_, pos, _), _) -> + flag_error pos + | _ -> + [] + in + + Printf.sprintf "%s::%s" namespace t, flags + +and get_native_marshalled_type value_type = + let marshal_type_parameter_to_string pos tcpp = + match tcpp with + | TCppMarshalNativeType (value_type, _) -> get_native_marshalled_type value_type + | TCppScalar _ + | TCppPointer _ + | TCppRawPointer _ + | TCppStar _ + | TCppVoidStar + | TCppStruct _ -> + tcpp_to_string_suffix "" tcpp + | _ -> + abort "CPP0003: Invalid parameter for a marshalling type" pos + in + + match value_type with + | ValueClass (cls, params) -> + build_type cls.cl_path cls.cl_pos params cls.cl_meta Meta.CppValueType (marshal_type_parameter_to_string cls.cl_pos) |> fst + | ValueEnum abs -> + build_type abs.a_path abs.a_pos [] abs.a_meta Meta.CppValueType (marshal_type_parameter_to_string abs.a_pos) |> fst + | Pointer (cls, params) -> + build_type cls.cl_path cls.cl_pos params cls.cl_meta Meta.CppPointerType (marshal_type_parameter_to_string cls.cl_pos) |> fst + and tcpp_objc_block_struct argTypes retType = let args = String.concat "," (List.map tcpp_to_string argTypes) in let ret = tcpp_to_string retType in @@ -424,15 +546,18 @@ and tcpp_objc_block_struct argTypes retType = and tcpp_to_string tcpp = tcpp_to_string_suffix "" tcpp and cpp_class_path_of klass params = - match get_meta_string klass.cl_meta Meta.Native with - | Some s -> - let typeParams = - match params with - | [] -> "" - | _ -> "< " ^ String.concat "," (List.map tcpp_to_string params) ^ " >" - in - " " ^ join_class_path_remap klass.cl_path "::" ^ typeParams - | None -> " ::" ^ join_class_path_remap klass.cl_path "::" + if is_marshalling_native_value_class klass then + get_native_marshalled_type (ValueClass (klass, params)) + else + match get_meta_string klass.cl_meta Meta.Native with + | Some s -> + let typeParams = + match params with + | [] -> "" + | _ -> "< " ^ String.concat "," (List.map tcpp_to_string params) ^ " >" + in + " " ^ join_class_path_remap klass.cl_path "::" ^ typeParams + | None -> " ::" ^ join_class_path_remap klass.cl_path "::" (* Get a string to represent a type. The "suffix" will be nothing or "_obj", depending if we want the name of the @@ -636,11 +761,13 @@ let rec cpp_is_struct_access t = | TCppFunction _ -> true | TCppStruct _-> false | TCppInst (class_def, _) -> Meta.has Meta.StructAccess class_def.cl_meta + | TCppReference (TCppMarshalNativeType _) -> true | TCppReference (r) -> cpp_is_struct_access r | _ -> false let rec cpp_is_native_array_access t = match t with + | TCppMarshalNativeType _ -> true | TCppStruct s -> cpp_is_native_array_access s | TCppReference s -> cpp_is_native_array_access s | TCppInst ({ cl_array_access = Some _ } as klass, _) when is_extern_class klass && Meta.has Meta.NativeArrayAccess klass.cl_meta -> true @@ -654,6 +781,9 @@ let cpp_is_dynamic_type = function let is_object_element member_type = match member_type with + | TCppMarshalManagedType _ + | TCppMarshalNativeType (_, Promoted) -> + true | TCppInst (x, _) | TCppInterface x -> not (is_extern_class x) @@ -678,6 +808,8 @@ let cpp_variant_type_of t = match t with | TCppObjectPtr | TCppReference _ | TCppStruct _ + | TCppMarshalNativeType _ + | TCppMarshalManagedType _ | TCppStar _ | TCppVoid | TCppFastIterator _ @@ -719,7 +851,8 @@ let cpp_cast_variant_type_of t = match t with | TCppDynamicArray | TCppClass | TCppEnum _ - | TCppInst _ -> t + | TCppInst _ + | TCppMarshalManagedType _ -> t | _ -> cpp_variant_type_of t let enum_getter_type t = diff --git a/src/generators/cpp/cppMarshalling.ml b/src/generators/cpp/cppMarshalling.ml new file mode 100644 index 00000000000..11f0211985e --- /dev/null +++ b/src/generators/cpp/cppMarshalling.ml @@ -0,0 +1,12 @@ +open CppAst +open CppAstTools + +let get_extern_value_type_boxed value_type = + let p = get_native_marshalled_type value_type in + let suffix = + match value_type with + | Pointer _ -> "*" + | _ -> "" + in + + Printf.sprintf "::cpp::marshal::Boxed< %s%s >" p suffix, Printf.sprintf "::cpp::marshal::Boxed_obj< %s%s >" p suffix \ No newline at end of file diff --git a/src/generators/cpp/cppRetyper.ml b/src/generators/cpp/cppRetyper.ml index 945c4160c36..3f91ebd2d47 100644 --- a/src/generators/cpp/cppRetyper.ml +++ b/src/generators/cpp/cppRetyper.ml @@ -7,40 +7,49 @@ open CppAst open CppAstTools open CppContext -let rec cpp_type_of stack haxe_type = - if List.exists (fast_eq haxe_type) stack then TCppDynamic +let with_reference_value_type () = Reference + +let with_promoted_value_type () = Promoted + +let with_stack_value_type () = Stack + +let rec cpp_type_of stack value_type_handler haxe_type = + if List.exists (fast_eq haxe_type) stack then + TCppDynamic else let stack = haxe_type :: stack in match haxe_type with | TMono r -> ( - match r.tm_type with - | None -> TCppDynamic - | Some t -> cpp_type_of stack t) + match r.tm_type with + | None -> TCppDynamic + | Some t -> cpp_type_of stack value_type_handler t) | TEnum (enum, params) -> TCppEnum enum | TInst ({ cl_path = [], "Array"; cl_kind = KTypeParameter _ }, _) -> - TCppObject + TCppObject | TInst ({ cl_kind = KTypeParameter _ }, _) -> TCppDynamic - | TInst (klass, params) -> cpp_instance_type stack klass params + | TInst (klass, params) -> + cpp_instance_type stack klass params value_type_handler + | TAbstract (abs, pl) when is_marshalling_native_enum abs -> + TCppMarshalNativeType (ValueEnum abs, value_type_handler()) | TAbstract (abs, pl) when not (Meta.has Meta.CoreType abs.a_meta) -> - cpp_type_from_path stack abs.a_path pl (fun () -> - cpp_type_of stack - (Abstract.get_underlying_type ~return_first:true abs pl)) + cpp_type_from_path stack abs.a_path pl value_type_handler (fun () -> + cpp_type_of stack value_type_handler (Abstract.get_underlying_type ~return_first:true abs pl)) | TAbstract (a, params) -> - cpp_type_from_path stack a.a_path params (fun () -> - if is_scalar_abstract a then - match get_meta_string a.a_meta Meta.Native with - | Some s -> TCppScalar s - | None -> TCppScalar (join_class_path a.a_path "::") - else TCppDynamic) + cpp_type_from_path stack a.a_path params value_type_handler (fun () -> + if is_scalar_abstract a then + match get_meta_string a.a_meta Meta.Native with + | Some s -> TCppScalar s + | None -> TCppScalar (join_class_path a.a_path "::") + else TCppDynamic) | TType (type_def, params) -> - cpp_type_from_path stack type_def.t_path params (fun () -> - cpp_type_of stack (apply_typedef type_def params)) + cpp_type_from_path stack type_def.t_path params value_type_handler (fun () -> + cpp_type_of stack value_type_handler (apply_typedef type_def params)) | TFun _ -> TCppObject | TAnon _ -> TCppObject | TDynamic _ -> TCppDynamic - | TLazy func -> cpp_type_of stack (lazy_type func) + | TLazy func -> cpp_type_of stack value_type_handler (lazy_type func) -and cpp_type_from_path stack path params default = +and cpp_type_from_path stack path params value_type_handler default = match (path, params) with | ([], "Void"), _ -> TCppVoid | ([], "void"), _ -> TCppVoid (* for old code with @:void *) @@ -67,22 +76,22 @@ and cpp_type_from_path stack path params default = | ([ "cpp" ], "AutoCast"), _ -> TCppAutoCast | ([], "String"), [] -> TCppString (* Things with type parameters hxcpp knows about ... *) - | ([ "cpp" ], "FastIterator"), [ p ] -> TCppFastIterator (cpp_type_of stack p) - | ([ "cpp" ], "Pointer"), [ p ] -> TCppPointer ("Pointer", cpp_type_of stack p) + | ([ "cpp" ], "FastIterator"), [ p ] -> TCppFastIterator (cpp_type_of stack value_type_handler p) + | ([ "cpp" ], "Pointer"), [ p ] -> TCppPointer ("Pointer", cpp_type_of stack value_type_handler p) | ([ "cpp" ], "ConstPointer"), [ p ] -> - TCppPointer ("ConstPointer", cpp_type_of stack p) - | ([ "cpp" ], "RawPointer"), [ p ] -> TCppRawPointer ("", cpp_type_of stack p) + TCppPointer ("ConstPointer", cpp_type_of stack value_type_handler p) + | ([ "cpp" ], "RawPointer"), [ p ] -> TCppRawPointer ("", cpp_type_of stack value_type_handler p) | ([ "cpp" ], "RawConstPointer"), [ p ] -> - TCppRawPointer ("const ", cpp_type_of stack p) + TCppRawPointer ("const ", cpp_type_of stack value_type_handler p) | ([ "cpp" ], "Function"), [ function_type; abi ] -> - cpp_function_type_of stack function_type abi + cpp_function_type_of stack function_type abi value_type_handler | ([ "cpp" ], "Callable"), [ function_type ] | ([ "cpp" ], "CallableData"), [ function_type ] -> - cpp_function_type_of_string stack function_type "" + cpp_function_type_of_string stack function_type "" value_type_handler | ("cpp" :: [ "objc" ], "ObjcBlock"), [ function_type ] -> - let args, ret = cpp_function_type_of_args_ret stack function_type in + let args, ret = cpp_function_type_of_args_ret stack value_type_handler function_type in TCppObjCBlock (args, ret) - | ([ "cpp" ], "Rest"), [ rest ] -> TCppRest (cpp_type_of stack rest) + | ([ "cpp" ], "Rest"), [ rest ] -> TCppRest (cpp_type_of stack value_type_handler rest) | ("cpp" :: [ "objc" ], "Protocol"), [ interface_type ] -> ( match follow interface_type with | TInst (klass, []) when has_class_flag klass CInterface -> @@ -92,83 +101,98 @@ and cpp_type_from_path stack path params default = print_endline "cpp.objc.Protocol must refer to an interface"; die "" __LOC__) | ([ "cpp" ], "Reference"), [ param ] -> - TCppReference (cpp_type_of stack param) - | ([ "cpp" ], "Struct"), [ param ] -> TCppStruct (cpp_type_of stack param) + TCppReference (cpp_type_of stack value_type_handler param) + | ([ "cpp" ], "Struct"), [ param ] -> TCppStruct (cpp_type_of stack value_type_handler param) | ([ "cpp" ], "Star"), [ param ] -> - TCppStar (cpp_type_of_pointer stack param, false) + TCppStar (cpp_type_of_pointer stack value_type_handler param, false) | ([ "cpp" ], "ConstStar"), [ param ] -> - TCppStar (cpp_type_of_pointer stack param, true) + TCppStar (cpp_type_of_pointer stack value_type_handler param, true) | ([], "Array"), [ p ] -> ( - let arrayOf = cpp_type_of stack p in + let arrayOf = cpp_type_of stack with_promoted_value_type p in match arrayOf with | TCppVoid (* ? *) | TCppDynamic -> TCppDynamicArray | TCppObject | TCppObjectPtr | TCppReference _ | TCppStruct _ | TCppStar _ | TCppEnum _ | TCppInst _ | TCppInterface _ | TCppProtocol _ | TCppClass - | TCppDynamicArray | TCppObjectArray _ | TCppScalarArray _ -> - TCppObjectArray arrayOf + | TCppDynamicArray | TCppObjectArray _ | TCppScalarArray _ | TCppMarshalNativeType _ + | TCppMarshalManagedType _ -> + TCppObjectArray arrayOf | _ -> TCppScalarArray arrayOf) - | ([], "Null"), [ p ] -> cpp_type_of_null stack p + | ([], "Null"), [ p ] -> cpp_type_of_null stack value_type_handler p | _ -> default () -and cpp_type_of_null stack p = - let baseType = cpp_type_of stack p in - if type_has_meta_key Meta.NotNull p || is_cpp_scalar baseType then TCppObject - else baseType +and cpp_type_of_null stack value_type_handler p = + match cpp_type_of stack with_promoted_value_type p with + | other when is_cpp_scalar other || type_has_meta_key Meta.NotNull p -> + TCppObject + | other -> + other -and cpp_type_of_pointer stack p = +and cpp_type_of_pointer stack value_type_handler p = match p with - | TAbstract ({ a_path = [], "Null" }, [ t ]) -> cpp_type_of stack t - | x -> cpp_type_of stack x + | TAbstract ({ a_path = [], "Null" }, [ t ]) -> cpp_type_of stack value_type_handler t + | x -> cpp_type_of stack value_type_handler x (* Optional types are Dynamic if they norally could not be null *) -and cpp_fun_arg_type_of stack tvar opt = +and cpp_fun_arg_type_of stack tvar opt value_type_handler = match opt with - | Some _ -> cpp_type_of_null stack tvar.t_type - | _ -> cpp_type_of stack tvar.t_type + | Some _ -> cpp_type_of_null stack value_type_handler tvar.t_type + | _ -> cpp_type_of stack value_type_handler tvar.t_type -and cpp_tfun_arg_type_of stack opt t = - if opt then cpp_type_of_null stack t else cpp_type_of stack t +and cpp_tfun_arg_type_of stack opt value_type_handler t = + if opt then cpp_type_of_null stack value_type_handler t else cpp_type_of stack value_type_handler t -and cpp_function_type_of stack function_type abi = +and cpp_function_type_of stack function_type abi value_type_handler = let abi = match follow abi with | TInst (klass1, _) -> get_meta_string klass1.cl_meta Meta.Abi |> Option.default "" | _ -> die "" __LOC__ in - cpp_function_type_of_string stack function_type abi + cpp_function_type_of_string stack function_type abi value_type_handler -and cpp_function_type_of_string stack function_type abi_string = - let args, ret = cpp_function_type_of_args_ret stack function_type in +and cpp_function_type_of_string stack function_type abi_string value_type_handler = + let args, ret = cpp_function_type_of_args_ret stack value_type_handler function_type in TCppFunction (args, ret, abi_string) -and cpp_function_type_of_args_ret stack function_type = +and cpp_function_type_of_args_ret stack value_type_handler function_type = match follow function_type with | TFun (args, ret) -> (* Optional types are Dynamic if they norally could not be null *) let cpp_arg_type_of (_, optional, haxe_type) = - if optional then cpp_type_of_null stack haxe_type - else cpp_type_of stack haxe_type + if optional then cpp_type_of_null stack value_type_handler haxe_type + else cpp_type_of stack value_type_handler haxe_type in - (List.map cpp_arg_type_of args, cpp_type_of stack ret) + (List.map cpp_arg_type_of args, cpp_type_of stack value_type_handler ret) | _ -> (* ? *) ([ TCppVoid ], TCppVoid) -and cpp_instance_type stack klass params = - cpp_type_from_path stack klass.cl_path params (fun () -> - if is_objc_class klass then TCppObjC klass - else if has_class_flag klass CInterface && is_native_gen_class klass then - TCppNativePointer klass - else if has_class_flag klass CInterface then TCppInterface klass - else if - has_class_flag klass CExtern && not (is_internal_class klass.cl_path) - then - let tcpp_params = List.map (cpp_type_of stack) params in - TCppInst (klass, tcpp_params) +and cpp_instance_type stack klass params value_type_handler = + let fallback_handler () = + if is_objc_class klass then TCppObjC klass + else if has_class_flag klass CInterface && is_native_gen_class klass then + TCppNativePointer klass + else if has_class_flag klass CInterface then + TCppInterface klass + else if has_class_flag klass CExtern && not (is_internal_class klass.cl_path) then + if is_marshalling_native_value_class klass then + let tcpp_params = List.map (cpp_type_of stack with_stack_value_type) params in + TCppMarshalNativeType (ValueClass (klass, tcpp_params), value_type_handler ()) + else if is_marshalling_native_pointer klass then + let tcpp_params = List.map (cpp_type_of stack with_stack_value_type) params in + TCppMarshalNativeType (Pointer (klass, tcpp_params), value_type_handler ()) + else if is_marshalling_managed_class klass then + let tcpp_params = List.map (cpp_type_of stack value_type_handler) params in + TCppMarshalManagedType (klass, tcpp_params) else - let tcpp_params = List.map (cpp_type_of stack) params in - TCppInst (klass, tcpp_params)) + let tcpp_params = List.map (cpp_type_of stack value_type_handler) params in + TCppInst (klass, tcpp_params) + else + let tcpp_params = List.map (cpp_type_of stack value_type_handler) params in + TCppInst (klass, tcpp_params) + in + + cpp_type_from_path stack klass.cl_path params value_type_handler fallback_handler let cpp_type_of = cpp_type_of [] let cpp_type_from_path = cpp_type_from_path [] @@ -185,7 +209,7 @@ type retyper_ctx = { closures : tcpp_closure list; injection : bool; declarations : unit StringMap.t; - undeclared : tvar StringMap.t; + undeclared : tcppvar StringMap.t; uses_this : tcppthis option; this_real : tcppthis; gc_stack : bool; @@ -194,6 +218,35 @@ type retyper_ctx = { loop_stack : (int * bool) list; } +let retype_tvar tvar = + let copying_var = + match tvar.v_kind with + | VUser (TVOLocalVariable | TVOArgument | TVOForVariable | TVOCatchVariable) + | VInlined + | VInlinedConstructorVariable _ -> true + | _ -> false + in + let handler = + if copying_var then + if has_var_flag tvar VCaptured then with_promoted_value_type else with_stack_value_type + else + with_reference_value_type + in + + { + tcppv_var = tvar; + tcppv_type = cpp_type_of handler tvar.v_type; + tcppv_name = cpp_var_name_of tvar; + tcppv_debug_name = keyword_remap tvar.v_name + } + +let retype_arg handler (name, opt, t) = + { + tfa_name = keyword_remap name; + tfa_optional = opt; + tfa_type = cpp_type_of handler t + } + let expression ctx request_type function_args function_type expression_tree forInjection = let forCppia = Gctx.defined ctx.ctx_common Define.Cppia in let initial_ctx = { @@ -201,11 +254,11 @@ 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, ()) |> string_map_of_list |> StringMap.add "__trace" (); (* '__trace' is at the top-level *) + declarations = function_args |> List.map (fun (v, _) -> v.tcppv_name, ()) |> string_map_of_list |> StringMap.add "__trace" (); (* '__trace' is at the top-level *) uses_this = None; this_real = if ctx.ctx_real_this_ptr then ThisReal else ThisDynamic; gc_stack = false; - function_return_type = cpp_type_of function_type; + function_return_type = function_type; goto_id = 0; loop_stack = []; } in @@ -234,19 +287,8 @@ let expression ctx request_type function_args function_type expression_tree forI new_ctx, resolver in - let cpp_const_type retyper_ctx cval = - match cval with - | 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 *) - (retyper_ctx, CppNull, TCppNull) - in - let cpp_return_type haxe_type = - match haxe_type with TFun (_, ret) -> cpp_type_of ret | _ -> TCppDynamic + match haxe_type with TFun (_, ret) -> cpp_type_of with_stack_value_type ret | _ -> TCppDynamic in let cpp_member_return_type member = cpp_return_type member.cf_type in @@ -263,14 +305,13 @@ let expression ctx request_type function_args function_type expression_tree forI let rec to_lvalue value = match value.cppexpr with - | CppVar (VarClosure var as varloc) - when is_gc_element ctx (cpp_type_of var.v_type) -> + | CppVar (VarClosure var as varloc) when is_gc_element ctx var.tcppv_type -> (CppVarRef varloc, true) | CppVar (VarThis (member, _) as varloc) - when is_gc_element ctx (cpp_type_of member.cf_type) -> + when is_gc_element ctx (cpp_type_of with_promoted_value_type member.cf_type) -> (CppVarRef varloc, true) | CppVar (VarInstance (obj, member, _, "->") as varloc) - when is_gc_element ctx (cpp_type_of member.cf_type) -> + when is_gc_element ctx (cpp_type_of with_promoted_value_type member.cf_type) -> (CppVarRef varloc, true) | CppVar varloc -> (CppVarRef varloc, false) | CppArray arrayloc -> @@ -334,12 +375,12 @@ let expression ctx request_type function_args function_type expression_tree forI let cpp_can_static_cast funcType inferredType = match funcType with - | TCppReference _ | TCppStar _ | TCppStruct _ -> false + | TCppReference _ | TCppStar _ | TCppStruct _ | TCppMarshalNativeType _ -> false | _ -> ( match inferredType with | TCppInst (cls, _) when is_extern_class cls -> false | TCppEnum e when is_extern_enum e -> false - | TCppInst _ | TCppClass | TCppEnum _ -> + | TCppInst _ | TCppClass | TCppEnum _ | TCppMarshalManagedType _ -> tcpp_to_string funcType <> tcpp_to_string inferredType | _ -> false) in @@ -362,7 +403,7 @@ let expression ctx request_type function_args function_type expression_tree forI in let is_instance_compare = function - | TCppInterface _ | TCppInst _ -> true + | TCppInterface _ | TCppInst _ | TCppMarshalManagedType _ -> true | _ -> false in @@ -386,7 +427,8 @@ let expression ctx request_type function_args function_type expression_tree forI (* Core Retyping *) let rec retype retyper_ctx return_type expr = - let cpp_type_of t = cpp_type_of t in + let cpp_type_of_with handler t = cpp_type_of handler t in + let cpp_type_of t = cpp_type_of with_reference_value_type t in let mk_cppexpr newExpr newType = { cppexpr = newExpr; cpptype = newType; cpppos = expr.epos } in @@ -417,7 +459,7 @@ let expression ctx request_type function_args function_type expression_tree forI ( retyper_ctx, CppThis retyper_ctx.this_real, if retyper_ctx.this_real = ThisDynamic then TCppDynamic - else cpp_type_of expr.etype ) + else cpp_type_of_with with_reference_value_type expr.etype ) | TConst TSuper -> let retyper_ctx = { retyper_ctx with uses_this = Some retyper_ctx.this_real } in ( retyper_ctx, @@ -425,20 +467,34 @@ let expression ctx request_type function_args function_type expression_tree forI if retyper_ctx.this_real = ThisDynamic then TCppDynamic else cpp_type_of expr.etype ) | TConst TNull when is_objc_type expr.etype -> (retyper_ctx, CppNil, TCppNull) - | TConst x -> cpp_const_type retyper_ctx x + | TConst x -> + (match x with + | 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 *) + (* We want to preserve the original type with a null marshal type as these may be handled differently in filtering *) + (match return_type with + | TCppMarshalNativeType _ -> + (retyper_ctx, CppNull, return_type) + | _ -> + (retyper_ctx, CppNull, TCppNull))) | TIdent "__global__" -> (* functions/vars will appear to be members of the virtual global object *) (retyper_ctx, CppClassOf (([], ""), false), TCppGlobal) | TLocal tvar -> - let name = tvar.v_name in - if StringMap.mem name retyper_ctx.declarations then - (retyper_ctx, CppVar (VarLocal tvar), cpp_type_of tvar.v_type) - else ( - 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)) + let new_var = retype_tvar tvar in + + if StringMap.mem new_var.tcppv_name retyper_ctx.declarations then + (retyper_ctx, CppVar (VarLocal new_var), new_var.tcppv_type) + else ( + let new_ctx = { retyper_ctx with undeclared = StringMap.add new_var.tcppv_name new_var retyper_ctx.undeclared } in + if has_var_flag tvar VCaptured then + (new_ctx, CppVar (VarClosure new_var), new_var.tcppv_type) + else + (new_ctx, CppExtern (new_var.tcppv_var.v_name, false), new_var.tcppv_type)) | TIdent name -> (retyper_ctx, CppExtern (name, false), return_type) | TBreak -> ( if forCppia then @@ -465,13 +521,17 @@ let expression ctx request_type function_args function_type expression_tree forI (retyper_ctx, cppType.cppexpr, cppType.cpptype) | TField (obj, field) -> ( match field with + | FClosure (Some (cls, _), _) when is_marshalling_native_value_class cls || is_marshalling_native_pointer cls -> + abort "CPP0002: Value types cannot have function closures created for them" expr.epos | 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 clazzType = cpp_instance_type clazz params with_reference_value_type 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 + (* Value types in haxe classes are always promoted, with value type externs treat them as stack types so the auto casting deals with conversion *) + let handler = if is_marshalling_native_value_class clazz then with_stack_value_type else with_promoted_value_type in + let exprType = cpp_type_of_with handler member.cf_type in + let is_objc = is_cpp_objc_type retypedObj.cpptype in if retypedObj.cpptype = TCppNull then (retyper_ctx, CppNullAccess, TCppDynamic) @@ -589,17 +649,22 @@ let expression ctx request_type function_args function_type expression_tree forI let funcReturn = cpp_member_return_type member in let exprType = cpp_type_of member.cf_type in (retyper_ctx, CppFunction (FuncFromStaticFunction, funcReturn), exprType) + | FStatic (({ cl_kind = KAbstractImpl abs }), member) when is_marshalling_native_enum abs -> + let exprType = cpp_type_of_with with_promoted_value_type member.cf_type in + let enum_name = Printf.sprintf "%s::%s" (get_native_marshalled_type (ValueEnum abs)) (member.cf_name) in + + (retyper_ctx, CppCall ((FuncNew exprType), [ mk_cppexpr (CppExtern (enum_name, false)) exprType ]), exprType) | FStatic (clazz, member) -> - let funcReturn = cpp_member_return_type member in - let exprType = cpp_type_of member.cf_type in + let exprType = cpp_type_of_with with_promoted_value_type member.cf_type in let objC = is_objc_class clazz in if is_var_field member then (retyper_ctx, CppVar (VarStatic (clazz, objC, member)), exprType) else ( retyper_ctx, - CppFunction (FuncStatic (clazz, objC, member), funcReturn), + CppFunction (FuncStatic (clazz, objC, member), cpp_member_return_type member), exprType ) - | FClosure (None, field) | FAnon field -> + | FClosure (None, field) + | FAnon field -> let retyper_ctx, obj = retype retyper_ctx TCppDynamic obj in let fieldName = field.cf_name in if obj.cpptype = TCppGlobal then @@ -615,7 +680,8 @@ let expression ctx request_type function_args function_type expression_tree forI ( retyper_ctx, CppFunction (FuncInternal (obj, fieldName, "->"), cppType), cppType ) - else (retyper_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) + else + (retyper_ctx, CppDynamicField (obj, field.cf_name), TCppVariant) | FDynamic fieldName -> let retyper_ctx, obj = retype retyper_ctx TCppDynamic obj in if obj.cpptype = TCppNull then (retyper_ctx, CppNullAccess, TCppDynamic) @@ -682,7 +748,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in match retypedArgs with | [ @@ -703,7 +769,7 @@ let expression ctx request_type function_args function_type expression_tree forI (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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in ( retyper_ctx, CppCall ( FuncInstance (obj, InstPtr, { member with cf_name = "removeRange" }), retypedArgs ), @@ -722,7 +788,14 @@ let expression ctx request_type function_args function_type expression_tree forI (retyper_ctx, CppAddressOf arg, TCppRawPointer ("", rawType)) | CppFunction (FuncStatic (obj, false, member), _) when member.cf_name = "::hx::StarOf" -> - let retyper_ctx, arg = retype retyper_ctx TCppUnchanged (List.hd args) in + let head = List.hd args in + let target_type = match cpp_type_of head.etype with + | TCppMarshalNativeType (value_type, _) -> + TCppMarshalNativeType (value_type, Reference) + | _ -> + TCppUnchanged + in + let retyper_ctx, arg = retype retyper_ctx target_type head in let rawType = match arg.cpptype with TCppReference x -> x | x -> x in (retyper_ctx, CppAddressOf arg, TCppStar (rawType, false)) | CppFunction (FuncStatic (obj, false, member), _) @@ -732,7 +805,7 @@ let expression ctx request_type function_args function_type expression_tree forI (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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in (* gc_stack - not needed yet *) match return_type with @@ -742,7 +815,7 @@ let expression ctx request_type function_args function_type expression_tree forI ( 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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in match retypedArgs with | { cppexpr = CppClassOf (path, native) } :: rest -> @@ -753,7 +826,7 @@ let expression ctx request_type function_args function_type expression_tree forI retypedFunc.cpppos) | CppFunction (FuncInstance (obj, InstPtr, member), _) when is_map_get_call obj member -> - let arg_types = List.map (fun _ -> TCppDynamic) args in + let arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let fname, cppType = match return_type with @@ -785,7 +858,7 @@ let expression ctx request_type function_args function_type expression_tree forI (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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let fname = match retypedArgs with @@ -802,7 +875,7 @@ let expression ctx request_type function_args function_type expression_tree forI | 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 arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let call = mk_cppexpr (CppCall (func, retypedArgs)) returnType @@ -825,7 +898,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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) + (fun (_, opt, t) -> cpp_tfun_arg_type_of opt with_reference_value_type t) real_types in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in @@ -835,28 +908,28 @@ let expression ctx request_type function_args function_type expression_tree forI | 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) + (fun (_, opt, t) -> cpp_tfun_arg_type_of opt with_reference_value_type t) arg_types in (* retype args specifically (not just CppDynamic) *) let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in (retyper_ctx, CppCall (func, retypedArgs), returnType) | CppFunction (func, returnType) -> - let arg_types = List.map (fun _ -> TCppDynamic) args in + let arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in (retyper_ctx, CppCall (func, retypedArgs), returnType) | CppEnumField (enum, field) -> (* TODO - proper re-typing *) - let arg_types = List.map (fun _ -> TCppDynamic) args in + let arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in ( retyper_ctx, CppCall (FuncEnumConstruct (enum, field), retypedArgs), cppType ) | CppSuper _ -> (* TODO - proper re-typing *) - let arg_types = List.map (fun _ -> TCppDynamic) args in + let arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in ( retyper_ctx, CppCall (FuncSuperConstruct retypedFunc.cpptype, retypedArgs), TCppVoid ) | CppDynamicField (expr, name) -> ( - let arg_types = List.map (fun _ -> TCppDynamic) args in + let arg_types = List.map (fun a -> cpp_type_of a.etype) args in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in (* Special function calls *) match (expr.cpptype, name) with @@ -894,12 +967,13 @@ let expression ctx request_type function_args function_type expression_tree forI | 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 arg_types, _ = cpp_function_type_of_args_ret with_stack_value_type constructor_type in let retyper_ctx, retypedArgs = retype_function_args retyper_ctx args arg_types in let created_type = cpp_type_of expr.etype in let gc_stack = retyper_ctx.gc_stack || match created_type with | TCppInst (t, _) -> not (is_native_class t) + | TCppMarshalManagedType _ -> true | _ -> false in ({ retyper_ctx with gc_stack = gc_stack }, CppCall (FuncNew created_type, retypedArgs), created_type) | TFunction func -> @@ -907,11 +981,11 @@ 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, ()) |> string_map_of_list; + declarations = func.tf_args |> List.map (fun (t, _) -> (retype_tvar t).tcppv_name, ()) |> string_map_of_list; undeclared = StringMap.empty; this_real = ThisFake; uses_this = None; - function_return_type = cpp_type_of func.tf_type; + function_return_type = cpp_type_of_with with_promoted_value_type func.tf_type; } in let new_ctx, cppExpr = retype new_ctx TCppVoid (mk_block func.tf_expr) in @@ -921,7 +995,7 @@ let expression ctx request_type function_args function_type expression_tree forI close_id = retyper_ctx.closure_id; close_undeclared = new_ctx.undeclared; close_type = new_ctx.function_return_type; - close_args = func.tf_args; + close_args = func.tf_args |> List.map (fun (t, e) -> retype_tvar t, e); close_this = new_ctx.uses_this; } in @@ -972,6 +1046,13 @@ let expression ctx request_type function_args function_type expression_tree forI ( retyper_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, TCppDynamic)), TCppDynamic ) + (* | TCppObjectArray TCppMarshalNativeType (cls, params, _) as elem -> + let inner = mk_cppexpr (CppArray (ArrayObject (retypedObj, retypedIdx, TCppDynamic))) elem in + let reference = TCppMarshalNativeType (cls, params, Reference) in + + ( retyper_ctx, + CppCast (inner, reference), + reference ) *) | TCppObjectArray elem -> (retyper_ctx, CppArray (ArrayObject (retypedObj, retypedIdx, elem)), elem) | TCppInst (({ cl_array_access = Some _ } as klass), _) -> @@ -1017,9 +1098,20 @@ let expression ctx request_type function_args function_type expression_tree forI retyper_ctx, cpp_type_of expr.etype | _ -> retyper_ctx, TCppUnchanged in - let retyper_ctx, e1 = retype retyper_ctx binOpType left in - let retyper_ctx, e2 = retype retyper_ctx binOpType right in - + (* If we have an unchanged type then use the type of the left and right expression as the overall type *) + (* This is needed to ensure we get references to value types from the auto cast filter *) + let l_type, r_type = + match binOpType with + | TCppUnchanged -> + cpp_type_of left.etype, cpp_type_of right.etype + (* if the left type is a value type then ensure the right type is a reference as we are doing assignment *) + | TCppMarshalNativeType (value_type, (Stack | Promoted)) as l -> + l, TCppMarshalNativeType (value_type, Reference) + | other -> + other, other + in + let retyper_ctx, e1 = retype retyper_ctx l_type left in + let retyper_ctx, e2 = retype retyper_ctx r_type right in let complex = is_complex_compare e1.cpptype || is_complex_compare e2.cpptype in @@ -1104,7 +1196,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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 el_types = List.map (fun e -> cpp_type_of e.etype) el in let retyper_ctx, retypedEls = retype_function_args retyper_ctx el el_types in (retyper_ctx, CppArrayDecl retypedEls, cpp_type_of expr.etype) | TBlock expr_list -> @@ -1130,9 +1222,9 @@ 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) = + let folder acc (name, var) = if not (StringMap.mem name retyper_ctx.declarations) then - StringMap.add name tvar acc + StringMap.add name var acc else acc in @@ -1164,22 +1256,24 @@ let expression ctx request_type function_args function_type expression_tree forI let el_names = List.map (fun ((v, _, _), _) -> v) el in let retyper_ctx, retyped_els = - List.map (fun _ -> TCppDynamic) el |> retype_function_args retyper_ctx el_exprs + List.map (fun (_, expr) -> cpp_type_of expr.etype) el |> retype_function_args retyper_ctx el_exprs in let joined = List.combine el_names retyped_els in match return_type with | TCppVoid -> (retyper_ctx, CppObjectDecl (joined, false), TCppVoid) | _ -> (retyper_ctx, CppObjectDecl (joined, false), TCppDynamic)) + | TVar (v, None) when is_marshalling_native_value_class_tvar v -> + abort "CPP0005: Marshalling value type extern cannot be used for a variable declaration with no expression" expr.epos | TVar (v, eo) -> - let varType = cpp_type_of v.v_type in + let new_var = retype_tvar v in let retyper_ctx, init = match eo with | None -> retyper_ctx, None - | Some e -> retype retyper_ctx varType e |> (fun (new_ctx, expr) -> new_ctx, Some expr) + | Some e -> retype retyper_ctx new_var.tcppv_type e |> (fun (new_ctx, expr) -> new_ctx, Some expr) in - let retyper_ctx = { retyper_ctx with declarations = StringMap.add v.v_name () retyper_ctx.declarations } in - (retyper_ctx, CppVarDecl (v, init), varType) + let retyper_ctx = { retyper_ctx with declarations = StringMap.add new_var.tcppv_name () retyper_ctx.declarations } in + (retyper_ctx, CppVarDecl (new_var, init), new_var.tcppv_type) | TIf (ec, e1, e2) -> let retyper_ctx, ec = retype retyper_ctx (TCppScalar "bool") ec in let blockify = @@ -1280,7 +1374,7 @@ let expression ctx request_type function_args function_type expression_tree forI 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, (retype_tvar tvar, cppCatchBlock) :: acc) (retyper_ctx, []) catches in @@ -1293,8 +1387,7 @@ let expression ctx request_type function_args function_type expression_tree forI CppReturn expr, TCppVoid ) | TCast (base, None) -> ( - (* Use auto-cast rules *) - let return_type = cpp_type_of expr.etype in + let return_type = cpp_type_of_with with_reference_value_type expr.etype 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 @@ -1302,10 +1395,14 @@ let expression ctx request_type function_args function_type expression_tree forI (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* nothing to do *)) else match return_type with + | TCppMarshalNativeType _ -> + (retyper_ctx, baseCpp.cppexpr, baseCpp.cpptype (* use autocasting rules *)) | TCppObjC k -> (retyper_ctx, CppCastObjC (baseCpp, k), return_type) | TCppPointer (_, _) | TCppRawPointer (_, _) - | TCppStar _ | TCppInst _ -> + | TCppStar _ + | TCppMarshalManagedType _ + | TCppInst _ -> (retyper_ctx, CppCast (baseCpp, return_type), return_type) | TCppString -> (retyper_ctx, CppCastScalar (baseCpp, "::String"), return_type) | TCppCode t when baseStr <> tcpp_to_string t -> @@ -1326,7 +1423,7 @@ let expression ctx request_type function_args function_type expression_tree forI else return_type in let return_type = - cpp_type_from_path (t_path t) [] (fun () -> default_return_type) + cpp_type_from_path (t_path t) [] with_reference_value_type (fun () -> default_return_type) in let returnStr = tcpp_to_string return_type in @@ -1343,143 +1440,15 @@ let expression ctx request_type function_args function_type expression_tree forI | _ -> (retyper_ctx, CppTCast (baseCpp, return_type), return_type)) in - let cppExpr = mk_cppexpr retypedExpr retypedType in - - (* Autocast rules... *) - if return_type = TCppVoid then - retyper_ctx, mk_cppexpr retypedExpr TCppVoid - else if return_type = TCppVarArg then - match cpp_variant_type_of cppExpr.cpptype with - | TCppVoidStar | TCppScalar _ -> retyper_ctx, cppExpr - | TCppString -> - retyper_ctx, mk_cppexpr - (CppVar (VarInternal (cppExpr, ".", "raw_ptr()"))) - (TCppPointer ("ConstPointer", TCppScalar "char")) - | TCppDynamic -> retyper_ctx, mk_cppexpr (CppCastNative cppExpr) TCppVoidStar - | _ -> - let toDynamic = - mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic - in - retyper_ctx, mk_cppexpr (CppCastNative toDynamic) TCppVoidStar - else if - cppExpr.cpptype = TCppVariant - || cppExpr.cpptype = TCppDynamic - || cppExpr.cpptype == TCppObject - then - match return_type with - | 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 - retyper_ctx, mk_cppexpr (CppCast (structCast, TCppInst (t, []))) (TCppInst (t, [])) - | TCppObjectArray _ | TCppScalarArray _ | TCppNativePointer _ - | TCppDynamicArray | TCppObjectPtr | TCppVarArg | TCppInst _ -> - retyper_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type - | TCppObjC k -> retyper_ctx, mk_cppexpr (CppCastObjC (cppExpr, k)) return_type - | TCppObjCBlock (ret, args) -> - retyper_ctx, mk_cppexpr (CppCastObjCBlock (cppExpr, ret, args)) return_type - | TCppScalar scalar -> - retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, scalar)) return_type - | TCppString -> - retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, "::String")) return_type - | TCppInterface _ when cppExpr.cpptype = TCppVariant -> - retyper_ctx, mk_cppexpr (CppCastVariant cppExpr) return_type - | TCppDynamic when cppExpr.cpptype = TCppVariant -> - 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 - retyper_ctx, mk_cppexpr - (CppCast (ptrCast, TCppStar (t, const))) - (TCppStar (t, const)) - | _ -> retyper_ctx, cppExpr - else - match (cppExpr.cpptype, return_type) with - | _, 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 - out the correct way to convert between them when one is expected, but another provided. - - TCppFunction: these do not really interact with the haxe function type, T - Since they are implemented with cpp::Function, conversion to/from Dynamic should happen automatically - CallableData = T; - FunctionData = T; - - TCppObjCBlock can move in and out of Dyanmic - ObjcBlock = T; - - TCppProtocol can move in and out of Dyanmic, via delegate creation - Protocol = T; - - Explicitly wrapped type - already interacts well with Dynamic and T - Struct = T; - - TCppStar, TCppStruct, TCppReference - for interacting with native code - Star = T; - ConstStar = T; - Reference = T; - T may be an extern class, with @:structAccess - in which case - Dynamic interaction must be handled explicitly - These types, plus Dynamic can be used interchangeably by haxe - Derived/inherited types may also be mixed in - *) - | TCppAutoCast, _ | TCppObjC _, TCppDynamic | TCppObjCBlock _, TCppDynamic - -> - 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 _ -> retyper_ctx, cppExpr - | TCppReference TCppDynamic, t -> retyper_ctx, mk_cppexpr retypedExpr (TCppReference t) - | TCppStar (TCppDynamic, _), TCppStar (_, _) -> retyper_ctx, cppExpr - | TCppStar (TCppDynamic, const), t -> - 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 - retyper_ctx, mk_cppexpr (CppCast (ptrCast, TCppDynamic)) TCppDynamic - | TCppStar (t, const), TCppReference _ - | TCppStar (t, const), TCppInst _ - | TCppStar (t, const), TCppStruct _ -> - retyper_ctx, mk_cppexpr (CppDereference cppExpr) return_type - | TCppInst (t, _), TCppStar _ - when is_native_class t - && - match cppExpr.cppexpr with - | CppCall (FuncNew _, _) -> true - | _ -> false -> - retyper_ctx, mk_cppexpr (CppNewNative cppExpr) return_type - | TCppInst _, TCppStar (p, const) | TCppStruct _, TCppStar (p, const) -> - retyper_ctx, mk_cppexpr (CppAddressOf cppExpr) return_type - | TCppObjectPtr, TCppObjectPtr -> retyper_ctx, cppExpr - | TCppObjectPtr, _ -> - retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppDynamic)) TCppDynamic - | TCppProtocol _, TCppProtocol _ -> retyper_ctx, cppExpr - | t, TCppProtocol protocol -> - 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 - retyper_ctx, mk_cppexpr (CppCast (structCast, TCppDynamic)) TCppDynamic - | _, TCppObjectPtr -> - retyper_ctx, mk_cppexpr (CppCast (cppExpr, TCppObjectPtr)) TCppObjectPtr - | TCppDynamicArray, TCppScalarArray _ - | TCppDynamicArray, TCppObjectArray _ - | TCppScalarArray _, TCppDynamicArray - | TCppObjectArray _, TCppDynamicArray - when forCppia -> - retyper_ctx, mk_cppexpr (CppCast (cppExpr, return_type)) return_type - | TCppScalar from, TCppScalar too when from <> too -> - retyper_ctx, mk_cppexpr (CppCastScalar (cppExpr, too)) return_type - | _ -> retyper_ctx, cppExpr + + (* Filter order is important *) + (* first thing we want to do is determine construction as autocast will then insert casts which can confuse things *) + retyper_ctx, + mk_cppexpr retypedExpr retypedType + |> CppFilterValueType.filter_determine_construction return_type + |> CppFilterAutoCast.autocast_filter forCppia return_type + |> CppFilterValueType.filter_value_enum_casting return_type + |> CppFilterValueType.filter_add_boxed_pointer_construction return_type in retype initial_ctx request_type expression_tree |> snd @@ -1516,15 +1485,17 @@ let native_field_name_remap field = let rec tcpp_class_from_tclass ctx ids slots class_def class_params = let scriptable = Gctx.defined ctx.ctx_common Define.Scriptable in - let create_function field func = { + let create_function field handler func = { tcf_field = field; tcf_name = native_field_name_remap field; + tcf_args = List.map (fun (v, i) -> retype_tvar v, i) func.tf_args; 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; + tcf_return = cpp_type_of handler func.tf_type } in let create_variable field = { @@ -1535,14 +1506,14 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = 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; + tcv_is_gc_element = cpp_type_of with_promoted_value_type field.cf_type |> is_gc_element ctx; } in let filter_functions is_static field = if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Method (MethNormal | MethInline), Some { eexpr = TFunction func } -> - Some (create_function field func) + Some (create_function field with_stack_value_type func) | Method MethNormal, _ when has_class_field_flag field CfAbstract -> (* We need to fetch the default values for abstract functions from the @:Value meta *) let abstract_tfunc = @@ -1583,7 +1554,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = die "expected abstract field type to be TFun" __LOC__ in - Some (create_function field abstract_tfunc) + Some (create_function field with_stack_value_type abstract_tfunc) | _ -> None else @@ -1594,10 +1565,10 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = if should_implement_field field then match (field.cf_kind, field.cf_expr) with | Method MethDynamic, Some { eexpr = TFunction func } -> - Some (create_function field func) + Some (create_function field with_promoted_value_type func) (* static variables with a default function value get a dynamic function generated as the implementation *) | Var _, Some { eexpr = TFunction func } when func_for_static_field -> - Some (create_function field func) + Some (create_function field with_promoted_value_type func) | _ -> None else @@ -1665,6 +1636,14 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = class_def.cl_ordered_fields |> List.filter_map filter_properties in + let constructor = + match class_def.cl_constructor with + | Some ({ cf_expr = Some { eexpr = TFunction definition } } as field) -> + Some (create_function field with_stack_value_type definition) + | _ -> + None + in + (* All interfaces (and sub-interfaces) implemented *) let rec folder (slots, haxe, native) (interface, _) = let slots, retyped = tcpp_interface_from_tclass ctx slots interface in @@ -1682,6 +1661,8 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = let (slots, ids, parent) = match class_def.cl_super with + | Some (cls, _) when Meta.has Meta.CppManagedType cls.cl_meta -> + abort "CPP0009: Class cannot extend a managed type extern" class_def.cl_pos | Some (cls, params) -> let slots, ids, parent = tcpp_class_from_tclass ctx ids slots cls params in (slots, ids, Some parent) @@ -1696,7 +1677,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = let gc_container_type = let type_cant_be_null t = - match cpp_type_of t with TCppScalar _ -> true | _ -> false in + match cpp_type_of with_promoted_value_type t with TCppScalar _ -> true | _ -> false in let rec gc_container variables super v = match List.exists (fun v -> not (type_cant_be_null v.tcv_type)) variables, super with @@ -1742,6 +1723,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params = tcl_dynamic_functions = dynamic_functions; tcl_haxe_interfaces = haxe_implementations; tcl_native_interfaces = native_implementations; + tcl_constructor = constructor; tcl_meta = meta_field; tcl_rtti = rtti_field; tcl_init = TClass.get_cl_init class_def; @@ -1753,7 +1735,7 @@ and tcpp_interface_from_tclass ctx slots class_def = let scriptable = Gctx.defined ctx.ctx_common Define.Scriptable && not class_def.cl_private in - let function_filter (slots, fields) field = + let function_filter handler (slots, fields) field = match (field.cf_type, field.cf_kind) with | TFun (args, ret), Method _ -> let slots = if scriptable then @@ -1764,8 +1746,8 @@ and tcpp_interface_from_tclass ctx slots class_def = let retyped = { iff_field = field; iff_name = native_field_name_remap field; - iff_args = args |> List.map (fun (name, opt, t) -> (keyword_remap name, opt, t)); - iff_return = ret; + iff_args = args |> List.map (retype_arg handler); + iff_return = cpp_type_of handler ret; iff_script_slot = CppAst.InterfaceSlots.find_opt field.cf_name slots } in (slots, retyped :: fields) @@ -1790,7 +1772,7 @@ and tcpp_interface_from_tclass ctx slots class_def = (slots, None) in - let slots, functions = List.fold_left function_filter (slots, []) class_def.cl_ordered_fields in + let slots, functions = List.fold_left (function_filter with_stack_value_type) (slots, []) class_def.cl_ordered_fields in let iface = { if_class = class_def; @@ -1812,12 +1794,19 @@ and tcpp_enum_from_tenum ctx ids enum_def = 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 strq = CppStrings.strq ctx.ctx_common in + let retype_args t = + match t with + TFun (args, _) -> + Some (List.map (retype_arg with_promoted_value_type) args) + | _ -> + None + 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}) + |> List.map (fun f -> { tef_field = f; tef_name = keyword_remap f.ef_name; tef_hash = strq f.ef_name; tef_args = retype_args f.ef_type }) in let enum = { te_enum = enum_def; te_id = self_id; te_constructors = constructors } in diff --git a/src/generators/cpp/cppTypeUtils.ml b/src/generators/cpp/cppTypeUtils.ml index ee4c96e3d83..adcb463e130 100644 --- a/src/generators/cpp/cppTypeUtils.ml +++ b/src/generators/cpp/cppTypeUtils.ml @@ -62,8 +62,45 @@ let is_internal_class = function | _ -> false +let is_marshalling_managed_class cls = + has_class_flag cls CExtern && has_meta Meta.CppManagedType cls.cl_meta + +let is_marshalling_native_enum a = + a.a_enum && a.a_extern && has_meta Meta.CppValueType a.a_meta + +let is_marshalling_native_value_class cls = + has_class_flag cls CExtern && has_meta Meta.CppValueType cls.cl_meta + +let is_marshalling_native_pointer cls = + has_class_flag cls CExtern && has_meta Meta.CppPointerType cls.cl_meta + +let is_marshalling_native_value_class_tvar tvar = + match follow tvar.v_type with + | TInst (cls, _) -> + is_marshalling_native_value_class cls + | _ -> + false + 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) + (is_extern_class class_def || is_native_gen_class class_def) && not (is_internal_class class_def.cl_path) && not (is_marshalling_native_value_class class_def) + +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) && not (is_marshalling_managed_class klass) + +let real_interfaces classes = + List.filter (function t, pl -> + (match (t, pl) with + | { cl_path = [ "cpp"; "rtti" ], _ }, [] -> false + | _ -> true)) + classes let can_quick_alloc klass = let rec implements_native_interface class_def = diff --git a/src/generators/cpp/filters/cppFilterAutoCast.ml b/src/generators/cpp/filters/cppFilterAutoCast.ml new file mode 100644 index 00000000000..f1bcada0788 --- /dev/null +++ b/src/generators/cpp/filters/cppFilterAutoCast.ml @@ -0,0 +1,196 @@ +open Type +open CppTypeUtils +open CppAst +open CppAstTools + +let autocast_filter for_cppia return_type cppexpr = + let object_expression = + match cppexpr.cpptype with + | TCppVariant + | TCppDynamic + | TCppObject -> true + | _ -> false + in + + let mk_cppexpr new_expr new_type = + { cppexpr = new_expr; cpptype = new_type; cpppos = cppexpr.cpppos } + in + + let cast_to_var_args () = + match cpp_variant_type_of cppexpr.cpptype with + | TCppVoidStar + | TCppScalar _ -> + cppexpr + | TCppString -> + mk_cppexpr + (CppVar (VarInternal (cppexpr, ".", "raw_ptr()") )) + (TCppPointer ("ConstPointer", TCppScalar "char")) + | TCppDynamic -> + mk_cppexpr (CppCastNative cppexpr) TCppVoidStar + | _ -> + let to_dynamic = mk_cppexpr (CppCast (cppexpr, TCppDynamic)) TCppDynamic in + mk_cppexpr (CppCastNative to_dynamic) TCppVoidStar + in + + let cast_from_object () = + match return_type with + | TCppUnchanged -> + cppexpr + | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta -> + let struct_type = TCppStruct inst in + let struct_cast = + mk_cppexpr (CppCast (cppexpr, struct_type)) struct_type + in + mk_cppexpr (CppCast (struct_cast, inst)) inst + | TCppObjectArray _ + | TCppScalarArray _ + | TCppNativePointer _ + | TCppDynamicArray + | TCppObjectPtr + | TCppVarArg + | TCppMarshalManagedType _ + | TCppInst _ -> + mk_cppexpr (CppCast (cppexpr, return_type)) return_type + | TCppObjC k -> + mk_cppexpr (CppCastObjC (cppexpr, k)) return_type + | TCppObjCBlock (ret, args) -> + mk_cppexpr (CppCastObjCBlock (cppexpr, ret, args)) return_type + | TCppScalar scalar -> + mk_cppexpr (CppCastScalar (cppexpr, scalar)) return_type + | TCppString -> + mk_cppexpr (CppCastScalar (cppexpr, "::String")) return_type + | TCppInterface _ when cppexpr.cpptype = TCppVariant -> + mk_cppexpr (CppCastVariant cppexpr) return_type + | TCppDynamic when cppexpr.cpptype = TCppVariant -> + mk_cppexpr (CppCastVariant cppexpr) return_type + | TCppStar (t, const) as ptr -> + let ptr_type = TCppPointer ((if const then "ConstPointer" else "Pointer"), t) in + let ptr_cast = mk_cppexpr (CppCast (cppexpr, ptr_type)) ptr_type in + mk_cppexpr (CppCast (ptr_cast, ptr)) ptr + (* When going from a dynamic or variant add an explicit cast so the ::cpp::marshal::Reference constructor + * takes care of checking the dynamic type *) + | TCppMarshalNativeType (_, _) -> + mk_cppexpr (CppCast (cppexpr, return_type)) return_type + | _ -> + cppexpr + in + + let cast_other () = + match (cppexpr.cpptype, return_type) with + | _, TCppUnchanged -> + cppexpr + (* + Using the 'typedef hack', where we use typedef X = T, allows the + haxe compiler to use these types interchangeably. We then work + out the correct way to convert between them when one is expected, but another provided. + + TCppFunction: these do not really interact with the haxe function type, T + Since they are implemented with cpp::Function, conversion to/from Dynamic should happen automatically + CallableData = T; + FunctionData = T; + + TCppObjCBlock can move in and out of Dyanmic + ObjcBlock = T; + + TCppProtocol can move in and out of Dyanmic, via delegate creation + Protocol = T; + + Explicitly wrapped type - already interacts well with Dynamic and T + Struct = T; + + TCppStar, TCppStruct, TCppReference - for interacting with native code + Star = T; + ConstStar = T; + Reference = T; + T may be an extern class, with @:structAccess - in which case + Dynamic interaction must be handled explicitly + These types, plus Dynamic can be used interchangeably by haxe + Derived/inherited types may also be mixed in + *) + | TCppAutoCast, _ + | TCppObjC _, TCppDynamic + | TCppObjCBlock _, TCppDynamic -> + 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 cppexpr.cppexpr (TCppReference t) + | TCppStar (TCppDynamic, _), TCppStar (_, _) -> + cppexpr + | TCppStar (TCppDynamic, const), t -> + mk_cppexpr cppexpr.cppexpr (TCppStar (t, const)) + | TCppStar (t, const), TCppDynamic -> + let ptr_type = TCppPointer ((if const then "ConstPointer" else "Pointer"), t) in + let ptr_cast = mk_cppexpr (CppCast (cppexpr, ptr_type)) ptr_type in + mk_cppexpr (CppCast (ptr_cast, TCppDynamic)) TCppDynamic + | TCppStar (t, const), TCppReference _ + | TCppStar (t, const), TCppInst _ + | TCppStar (t, const), TCppMarshalManagedType _ + | TCppStar (t, const), TCppStruct _ -> + 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 + | TCppInst _, TCppStar (p, const) + | TCppMarshalManagedType _, TCppStar (p, const) + | TCppStruct _, TCppStar (p, const) -> + mk_cppexpr (CppAddressOf cppexpr) return_type + | TCppObjectPtr, TCppObjectPtr -> + cppexpr + | TCppObjectPtr, _ -> + mk_cppexpr (CppCast (cppexpr, TCppDynamic)) TCppDynamic + | TCppProtocol _, TCppProtocol _ -> + cppexpr + | t, TCppProtocol protocol -> + mk_cppexpr (CppCastProtocol (cppexpr, protocol)) return_type + | TCppInst (t, _) as inst, TCppDynamic when Meta.has Meta.StructAccess t.cl_meta -> + let struct_type = TCppStruct inst in + let struct_cast = mk_cppexpr (CppCast (cppexpr, struct_type)) struct_type in + mk_cppexpr (CppCast (struct_cast, TCppDynamic)) TCppDynamic + | _, TCppObjectPtr -> + mk_cppexpr (CppCast (cppexpr, TCppObjectPtr)) TCppObjectPtr + | TCppDynamicArray, TCppScalarArray _ + | TCppDynamicArray, TCppObjectArray _ + | TCppScalarArray _, TCppDynamicArray + | TCppObjectArray _, TCppDynamicArray when for_cppia -> + mk_cppexpr (CppCast (cppexpr, return_type)) return_type + | TCppScalar from, TCppScalar too when from <> too -> + mk_cppexpr (CppCastScalar (cppexpr, too)) return_type + + (* If we are going between two pointers or value type classes which mismatch add a cast so the reference type reinterprets the pointer *) + (* This happens in inheritance related situations *) + | TCppMarshalNativeType ((ValueClass (fst_cls, fst_params) | Pointer (fst_cls, fst_params)), _), TCppMarshalNativeType ((ValueClass (snd_cls, snd_params) | Pointer (snd_cls, snd_params)) as dst, _) when not (fast_eq (TInst (fst_cls, [])) (TInst (snd_cls, []))) -> + let reference = TCppMarshalNativeType(dst, Reference) in + mk_cppexpr (CppCast (cppexpr, reference)) reference + + (* Ensure we wrap any access to the stack or promoted type in a reference object. *) + (* TIdents are wrapped at retyping but array access and others won't be, so this will wrap them. *) + | TCppMarshalNativeType (value_type, Stack), (TCppPointer _) + | TCppMarshalNativeType (value_type, Stack), (TCppRawPointer _) + | TCppMarshalNativeType (value_type, Stack), (TCppStar _) + | TCppMarshalNativeType (value_type, Stack), (TCppReference _) + | TCppMarshalNativeType (_, Stack), TCppMarshalNativeType (value_type, (Promoted)) -> + let reference = TCppMarshalNativeType(value_type, Reference) in + mk_cppexpr (CppCast (cppexpr, reference)) reference + | TCppMarshalNativeType (value_type, Promoted), (TCppPointer _) + | TCppMarshalNativeType (value_type, Promoted), (TCppRawPointer _) + | TCppMarshalNativeType (value_type, Promoted), (TCppStar _) + | TCppMarshalNativeType (value_type, Promoted), (TCppReference _) + | TCppMarshalNativeType (_, Promoted), TCppMarshalNativeType (value_type, (Stack)) -> + let reference = TCppMarshalNativeType(value_type, Reference) in + mk_cppexpr (CppCast (cppexpr, reference)) reference + | TCppMarshalNativeType (value_type, (Stack | Promoted)), (TCppMarshalNativeType (_, Reference) | TCppDynamic | TCppVariant) -> + let reference = TCppMarshalNativeType(value_type, Reference) in + mk_cppexpr (CppCast (cppexpr, reference)) reference + | _ -> cppexpr + in + + match return_type with + | TCppVoid -> + mk_cppexpr cppexpr.cppexpr TCppVoid + | TCppVarArg -> + cast_to_var_args () + | _ when object_expression -> + cast_from_object () + | _ -> + cast_other () \ No newline at end of file diff --git a/src/generators/cpp/filters/cppFilterValueType.ml b/src/generators/cpp/filters/cppFilterValueType.ml new file mode 100644 index 00000000000..51309716d80 --- /dev/null +++ b/src/generators/cpp/filters/cppFilterValueType.ml @@ -0,0 +1,74 @@ +open CppAst +open CppAstTools + +(* If we are constructing a value type of reference state, inspect the surrounding context and choose a more appropriate construction *) +let filter_determine_construction return_type cppexpr = + let mk_cppexpr new_expr new_type = + { cppexpr = new_expr; cpptype = new_type; cpppos = cppexpr.cpppos } + in + + match cppexpr.cpptype, return_type, cppexpr.cppexpr with + | TCppMarshalNativeType (value_type, Reference), TCppMarshalNativeType (_, Stack), CppCall ((FuncNew _), args) -> + let stack = TCppMarshalNativeType (value_type, Stack) in + { cppexpr with cpptype = stack; cppexpr = CppCall ((FuncNew stack), args) } + | TCppMarshalNativeType (value_type, Reference), TCppMarshalNativeType (_, Promoted), CppCall ((FuncNew _), args) -> + let promoted = TCppMarshalNativeType (value_type, Promoted) in + { cppexpr with cpptype = promoted; cppexpr = CppCall ((FuncNew promoted), args) } + (* When constructing to a reference we lack enough info to make a more precise choice *) + (* So just allocate on the stack and wrap in a reference *) + (* This comes up with function calls e.g. foo(new MyValueType()) *) + (* TFun does not give us enough info to make a more precise allocation *) + | TCppMarshalNativeType (value_type, Reference), _, CppCall ((FuncNew _), args) -> + let stack = TCppMarshalNativeType(value_type, Stack) in + let reference = TCppMarshalNativeType(value_type, Reference) in + mk_cppexpr (CppCast ({ cppexpr with cpptype = stack; cppexpr = CppCall ((FuncNew stack), args) }, reference)) reference + | _ -> + cppexpr + +(* Handle casting to and from value type enums and scalar values *) +let rec filter_value_enum_casting return_type cppexpr = + let mk_cppexpr new_expr new_type = + { cppexpr = new_expr; cpptype = new_type; cpppos = cppexpr.cpppos } + in + + match cppexpr.cpptype, return_type with + (* Casting from from a scalar to a value type enum *) + | TCppScalar s, (TCppMarshalNativeType ((ValueEnum abs), (Stack | Promoted))) -> + let casted = mk_cppexpr (CppCastScalar (cppexpr, get_native_marshalled_type (ValueEnum abs))) return_type in + mk_cppexpr (CppCall ((FuncNew return_type), [ casted ])) return_type + + | TCppScalar s, (TCppMarshalNativeType ((ValueEnum _ as e), Reference)) -> + let promoted = filter_value_enum_casting (TCppMarshalNativeType (e, Promoted)) cppexpr in + mk_cppexpr (CppCast (promoted, return_type)) return_type + + (* Casting going from a value type enum to a scalar *) + | TCppMarshalNativeType ((ValueEnum _ as e), (Stack | Promoted)), TCppScalar s -> + let reference = TCppMarshalNativeType(e, Reference) in + let casted = mk_cppexpr (CppCast (cppexpr, reference)) reference in + filter_value_enum_casting return_type casted + | TCppMarshalNativeType ((ValueEnum _), Reference), TCppScalar s -> + let dereference = mk_cppexpr (CppDereference (cppexpr)) cppexpr.cpptype in + mk_cppexpr (CppCastScalar (dereference, s)) return_type + | _ -> + cppexpr + +let filter_add_boxed_pointer_construction return_type cppexpr = + let mk_cppexpr new_expr new_type = + { cppexpr = new_expr; cpptype = new_type; cpppos = cppexpr.cpppos } + in + + match return_type, cppexpr.cppexpr with + (* | CppVarDecl (var, Some expr) when is_pointer_type var.tcppv_type -> + let construct = mk_cppexpr (CppCall ((FuncNew var.tcppv_type), [ expr ])) var.tcppv_type in + { cppexpr with cppexpr = CppVarDecl(var, Some construct) } + | CppVarDecl (var, None) when is_pointer_type var.tcppv_type -> + let construct = mk_cppexpr (CppCall ((FuncNew var.tcppv_type), [])) var.tcppv_type in + { cppexpr with cppexpr = CppVarDecl(var, Some construct) } *) + | TCppMarshalNativeType ((Pointer _), (Stack | Promoted)), CppNull -> + mk_cppexpr (CppCall ((FuncNew return_type), [ cppexpr ])) return_type + | TCppMarshalNativeType ((Pointer _ as value_type), Reference), CppNull -> + let stack = TCppMarshalNativeType (value_type, Stack) in + let ctor = mk_cppexpr (CppCall ((FuncNew stack), [ cppexpr ])) stack in + mk_cppexpr (CppCast (ctor, return_type)) return_type + | _ -> + cppexpr \ No newline at end of file diff --git a/src/generators/cpp/gen/cppCppia.ml b/src/generators/cpp/gen/cppCppia.ml index 1581322c1f4..de70a48f0f0 100644 --- a/src/generators/cpp/gen/cppCppia.ml +++ b/src/generators/cpp/gen/cppCppia.ml @@ -7,37 +7,56 @@ open CppAst open CppAstTools open CppContext -let cpp_type_of = CppRetyper.cpp_type_of - -let script_type t optional = if optional then begin - match type_string t with - | "::String" -> "String" - | _ -> "Object" - end else match type_string t with - | "bool" -> "Int" - | "int" | "::cpp::Int32" -> "Int" - | "Float" -> "Float" - | "::String" -> "String" - | "Null" -> "Void" - | "Void" -> "Void" - | "float" | "::cpp::Float32" | "::cpp::Float64" -> "Float" - | "::cpp::Int64" | "::cpp::UInt64" -> "Object" - | _ -> "Object" - -let script_signature t optional = match script_type t optional with - | "Bool" -> "b" - | "Int" -> "i" - | "Float" -> "f" - | "String" -> "s" - | "Void" -> "v" - | "void" -> "v" - | _ -> "o" - -let script_size_type t optional = match script_type t optional with - | "Object" -> "void *" - | "Int" -> "int" - | "Bool" -> "bool" - | x -> x +type script_type = + | ScriptBool + | ScriptInt + | ScriptFloat + | ScriptString + | ScriptObject + | ScriptVoid + +let cpp_type_of = CppRetyper.cpp_type_of CppRetyper.with_reference_value_type + +let to_script_type tcpp = + match tcpp with + | TCppScalar "bool" -> ScriptBool + | TCppScalar "int" + | TCppScalar "::cpp::Int32" -> ScriptInt + | TCppScalar "float" + | TCppScalar "double" + | TCppScalar "Float" + | TCppScalar "::cpp::Float32" + | TCppScalar "::cpp::Float64" -> ScriptFloat + | TCppString -> ScriptString + | TCppVoid -> ScriptVoid + | _ -> ScriptObject + +let to_script_type_signature script_type = + match script_type with + | ScriptBool -> "b" + | ScriptInt -> "i" + | ScriptFloat -> "f" + | ScriptString -> "s" + | ScriptVoid -> "v" + | ScriptObject -> "o" + +let to_script_type_string script_type = + match script_type with + | ScriptBool + | ScriptInt -> "Int" + | ScriptFloat -> "Float" + | ScriptString -> "String" + | ScriptVoid -> "Void" + | ScriptObject -> "Object" + +let to_script_type_size script_type = + match script_type with + | ScriptBool + | ScriptInt -> "int" + | ScriptObject -> "void*" + | ScriptFloat -> "Float" + | ScriptString -> "String" + | v -> to_script_type_string v let rec script_type_string haxe_type = match haxe_type with @@ -77,7 +96,7 @@ let rec script_type_string haxe_type = let rec script_cpptype_string cppType = match cppType with - | TCppDynamic | TCppUnchanged | TCppWrapped _ | TCppObject -> "Dynamic" + | TCppDynamic | TCppUnchanged | TCppWrapped _ | TCppObject | TCppMarshalManagedType _ -> "Dynamic" | TCppObjectPtr -> ".*.hx.Object*" | TCppReference t -> ".ref." ^ script_cpptype_string t | TCppStruct t -> ".struct." ^ script_cpptype_string t @@ -96,6 +115,12 @@ let rec script_cpptype_string cppType = "cpp.Pointer." ^ script_cpptype_string valueType | TCppRawPointer (_, valueType) -> "cpp.RawPointer." ^ script_cpptype_string valueType + | TCppMarshalNativeType (ValueClass (cls, _), _) -> + "cpp.MarshalValueClass." ^ (join_class_path cls.cl_path ".") + | TCppMarshalNativeType (ValueEnum abs, _) -> + "cpp.MarshalValueEnum." ^ join_class_path abs.a_path "." + | TCppMarshalNativeType (Pointer (cls, _), _) -> + "cpp.MarshalPointer." ^ join_class_path cls.cl_path "." | TCppFunction _ -> "cpp.Function" | TCppObjCBlock _ -> "cpp.ObjCBlock" | TCppDynamicArray -> "Array.Any" @@ -730,9 +755,9 @@ class script_writer ctx filename asciiOut = match fieldExpression with | Some ({ eexpr = TFunction function_def } as e) -> if cppiaAst then ( - let args = List.map fst function_def.tf_args in + let args = List.map (fun (v, e) -> (CppRetyper.retype_tvar v), e) function_def.tf_args in let cppExpr = - CppRetyper.expression ctx TCppVoid args function_def.tf_type + CppRetyper.expression ctx TCppVoid args (cpp_type_of function_def.tf_type) function_def.tf_expr false in this#begin_expr; @@ -742,7 +767,7 @@ class script_writer ctx filename asciiOut = ^ this#typeText function_def.tf_type ^ string_of_int (List.length args) ^ "\n"); - let close = this#gen_func_args function_def.tf_args in + let close = this#gen_func_args args in this#gen_expression_tree cppExpr; this#end_expr; close ()) @@ -766,7 +791,7 @@ class script_writer ctx filename asciiOut = if cppiaAst then let varType = cpp_type_of expression.etype in let cppExpr = - CppRetyper.expression ctx varType [] t_dynamic expression false + CppRetyper.expression ctx varType [] TCppDynamic expression false in this#gen_expression_tree cppExpr else this#gen_expression expression @@ -863,7 +888,7 @@ class script_writer ctx filename asciiOut = List.iter (fun (arg, init) -> this#write (indent ^ indent_str); - this#writeVar arg; + this#writeVar arg.tcppv_var; match init with | Some { eexpr = TConst TNull } -> this#write "0\n" | Some const -> @@ -893,8 +918,8 @@ class script_writer ctx filename asciiOut = this#begin_expr; this#writePos const; this#write - (this#op IaVar ^ string_of_int arg.v_id - ^ this#commentOf arg.v_name); + (this#op IaVar ^ string_of_int arg.tcppv_var.v_id + ^ this#commentOf arg.tcppv_var.v_name); this#end_expr in @@ -929,7 +954,7 @@ class script_writer ctx filename asciiOut = ^ this#typeText function_def.tf_type ^ string_of_int (List.length function_def.tf_args) ^ "\n"); - let close = this#gen_func_args function_def.tf_args in + let close = this#gen_func_args (List.map (fun (v, e) -> CppRetyper.retype_tvar v, e) function_def.tf_args) in let pop = this#pushReturn function_def.tf_type in this#gen_expression function_def.tf_expr; pop (); @@ -1313,19 +1338,18 @@ class script_writer ctx filename asciiOut = this#writeList (this#op IaBlock) (List.length exprs); List.iter gen_expression exprs | CppVarDecl (var, init) -> ( - let name = CppGen.cpp_var_name_of var in this#write (this#op IaTVars ^ string_of_int 1 - ^ this#commentOf (name ^ ":" ^ script_type_string var.v_type) + ^ this#commentOf (var.tcppv_name ^ ":" ^ script_type_string var.tcppv_var.v_type) ^ "\n"); this#write ("\t\t" ^ indent); match init with | None -> this#writeOp IaVarDecl; - this#writeVar var + this#writeVar var.tcppv_var | Some init -> this#writeOp IaVarDeclI; - this#writeVar var; + this#writeVar var.tcppv_var; this#write (" " ^ this#astType init.cpptype); this#write "\n"; gen_expression init) @@ -1606,9 +1630,9 @@ class script_writer ctx filename asciiOut = this#writeList (this#op IaTry) (List.length catches); gen_expression block; List.iter - (fun (tvar, catch_expr) -> + (fun (var, catch_expr) -> this#write ("\t\t\t" ^ indent); - this#writeVar tvar; + this#writeVar var.tcppv_var; this#write "\n"; gen_expression catch_expr) catches @@ -1715,8 +1739,8 @@ class script_writer ctx filename asciiOut = match loc with | VarClosure var | VarLocal var -> this#write - (this#op IaVar ^ string_of_int var.v_id - ^ this#commentOf var.v_name) + (this#op IaVar ^ string_of_int var.tcppv_var.v_id + ^ this#commentOf var.tcppv_var.v_name) | VarStatic (class_def, _, field) -> this#write (this#op IaFStatic ^ this#cppInstText class_def ^ " " diff --git a/src/generators/cpp/gen/cppGen.ml b/src/generators/cpp/gen/cppGen.ml index 4d382805c6d..a89b289acb7 100644 --- a/src/generators/cpp/gen/cppGen.ml +++ b/src/generators/cpp/gen/cppGen.ml @@ -9,6 +9,7 @@ open CppAst open CppAstTools open CppSourceWriter open CppContext +open CppMarshalling type tinject = { inj_prologue : bool -> unit; @@ -16,60 +17,50 @@ type tinject = { inj_tail : string; } -let cpp_type_of = CppRetyper.cpp_type_of +let cpp_type_of = CppRetyper.cpp_type_of CppRetyper.with_stack_value_type let cpp_type_of_null = CppRetyper.cpp_type_of_null let cpp_instance_type = CppRetyper.cpp_instance_type let type_to_string haxe_type = tcpp_to_string (cpp_type_of haxe_type) -let type_cant_be_null haxe_type = - match cpp_type_of haxe_type with TCppScalar _ -> true | _ -> false +let type_cant_be_null tcpp = + match tcpp with TCppScalar _ -> true | _ -> false + +let type_arg_to_string v default_val prefix = + let remap_name = v.tcppv_name in + let type_str = tcpp_to_string v.tcppv_type in -let type_arg_to_string name default_val arg_type prefix = - let remap_name = keyword_remap name in - let type_str = type_to_string arg_type in match default_val with | Some { eexpr = TConst TNull } -> (type_str, remap_name) - | Some constant when type_cant_be_null arg_type -> + | Some constant when match v.tcppv_type with TCppScalar _ -> true | _ -> false -> ("::hx::Null< " ^ type_str ^ " > ", prefix ^ remap_name) | Some constant -> (type_str, prefix ^ remap_name) | _ -> (type_str, remap_name) -let cpp_var_name_of var = - match get_meta_string var.v_meta Meta.Native with - | Some n -> n - | None -> keyword_remap var.v_name - -let cpp_var_debug_name_of v = - match get_meta_string v.v_meta Meta.RealPath with - | Some n -> n - | None -> v.v_name - (* Generate prototype text, including allowing default values to be null *) -let print_arg name default_val arg_type prefix = - let n, t = type_arg_to_string name default_val arg_type prefix in +let print_arg v default_val prefix = + let n, t = type_arg_to_string v default_val prefix in n ^ " " ^ t (* Generate prototype text, including allowing default values to be null *) -let print_arg_name name default_val arg_type prefix = - let n, _ = type_arg_to_string name default_val arg_type prefix in - n +let print_arg_name v default_val prefix = + type_arg_to_string v default_val prefix |> fst let print_arg_list arg_list prefix = String.concat "," - (List.map (fun (v, o) -> print_arg v.v_name o v.v_type prefix) arg_list) + (List.map (fun (v, o) -> print_arg v o prefix) arg_list) let print_arg_list_name arg_list prefix = String.concat "," (List.map - (fun (v, o) -> print_arg_name v.v_name o v.v_type prefix) + (fun (v, o) -> print_arg_name v o prefix) arg_list) let print_arg_names args = - String.concat "," (List.map (fun (name, _, _) -> keyword_remap name) args) + args |> List.map (fun arg -> arg.tfa_name) |> String.concat ", " -let print_tfun_arg_list include_names arg_list = +let print_retyped_tfun_arg_list include_names arg_list = let oType o arg_type = - let type_str = type_to_string arg_type in + let type_str = tcpp_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 ^ " > " @@ -77,7 +68,7 @@ let print_tfun_arg_list include_names arg_list = type_str in arg_list - |> List.map (fun (name, o, arg_type) -> (oType o arg_type) ^ (if include_names then " " ^ keyword_remap name else "")) + |> List.map (fun arg -> (oType arg.tfa_optional arg.tfa_type) ^ (if include_names then " " ^ arg.tfa_name else "")) |> String.concat "," let cpp_member_name_of member = @@ -86,6 +77,12 @@ let cpp_member_name_of member = | None -> keyword_remap member.cf_name let function_signature include_names tfun abi = + let print_tfun_arg_list include_names arg_list = + arg_list + |> List.map (CppRetyper.retype_arg CppRetyper.with_stack_value_type) + |> print_retyped_tfun_arg_list include_names + in + match follow tfun with | TFun (args, ret) -> type_to_string ret ^ " " ^ abi ^ "(" @@ -95,64 +92,49 @@ let function_signature include_names tfun abi = let cpp_no_debug_synbol ctx var = ctx.ctx_debug_level <= 1 - || (match var.v_kind with VUser _ -> false | _ -> true) + || (match var.tcppv_var.v_kind with VUser _ -> false | _ -> true) || - match cpp_type_of var.v_type with - | TCppStar _ | TCppReference _ -> true + match var.tcppv_type with + | TCppStar _ | TCppReference _ | TCppMarshalNativeType _ -> true | TCppInst (class_def, _) when Meta.has Meta.StructAccess class_def.cl_meta -> true | TCppInst (class_def, _) when Meta.has Meta.Unreflective class_def.cl_meta -> true | _ -> - let name = cpp_var_debug_name_of var in + let name = cpp_var_debug_name_of var.tcppv_var in String.length name > 4 && String.sub name 0 4 = "_hx_" -let cpp_debug_name_of var = keyword_remap var.v_name let cpp_debug_var_visible ctx var = not (cpp_no_debug_synbol ctx (fst var)) -let cpp_var_type_of var = tcpp_to_string (cpp_type_of var.v_type) +(* let cpp_var_type_of var = tcpp_to_string (cpp_type_of var.v_type) *) let mk_injection prologue set_var tail = Some { inj_prologue = prologue; inj_setvar = set_var; inj_tail = tail } -let tvar_arg_to_string tvar default_val prefix = - let remap_name = cpp_var_name_of tvar in - let type_str = cpp_var_type_of tvar in - match default_val with - | Some { eexpr = TConst TNull } -> - (tcpp_to_string (cpp_type_of_null tvar.v_type), remap_name) - | Some constant -> - (tcpp_to_string (cpp_type_of_null tvar.v_type), prefix ^ remap_name) - | _ -> (type_str, remap_name) - -(* Generate prototype text, including allowing default values to be null *) -let cpp_arg_string tvar default_val prefix = - let t, n = tvar_arg_to_string tvar default_val prefix in - t ^ " " ^ n - -let cpp_arg_list args prefix = - String.concat "," (List.map (fun (v, o) -> cpp_arg_string v o prefix) args) - let gen_type ctx haxe_type = ctx.ctx_output (type_to_string haxe_type) let cpp_macro_var_type_of var = - let t = tcpp_to_string (cpp_type_of var.v_type) in + let t = tcpp_to_string var.tcppv_type in if String.contains t ',' then Str.global_replace (Str.regexp ",") " HX_COMMA " t else t let cpp_class_name klass = - let globalNamespace = - match get_meta_string klass.cl_meta Meta.Native with - | Some _ -> "" - | None -> "::" - in - let path = globalNamespace ^ join_class_path_remap klass.cl_path "::" in - if is_native_class klass || path = "::String" then path else path ^ "_obj" - -let only_stack_access haxe_type = - match cpp_type_of haxe_type with - | TCppInst (klass, _) -> Meta.has Meta.StackOnly klass.cl_meta - | _ -> false + if is_marshalling_native_value_class klass then + get_native_marshalled_type (ValueClass (klass, [])) + else if is_marshalling_native_pointer klass then + get_native_marshalled_type (Pointer (klass, [])) + else if is_marshalling_managed_class klass then + let type_str, flags = build_type klass.cl_path klass.cl_pos [] klass.cl_meta Meta.CppManagedType tcpp_to_string in + let standard_naming = List.exists (fun f -> f = "StandardNaming") flags in + if standard_naming then type_str ^ "_obj" else type_str + else + let globalNamespace = + match get_meta_string klass.cl_meta Meta.Native with + | Some _ -> "" + | None -> "::" + in + let path = globalNamespace ^ join_class_path_remap klass.cl_path "::" in + if is_native_class klass || path = "::String" then path else path ^ "_obj" let cpp_is_static_extension member = Meta.has Meta.NativeStaticExtension member.cf_meta @@ -178,34 +160,28 @@ let default_value_string ctx value = let cpp_gen_default_values ctx args prefix = List.iter - (fun (tvar, o) -> - let vtype = cpp_type_of tvar.v_type in + (fun (var, o) -> let not_null = - type_has_meta_key Meta.NotNull tvar.v_type || is_cpp_scalar vtype + type_has_meta_key Meta.NotNull var.tcppv_var.v_type || is_cpp_scalar var.tcppv_type in match o with | Some { eexpr = TConst TNull } -> () | Some const -> - let name = cpp_var_name_of tvar in - let spacer = - if ctx.ctx_debug_level > 0 then " \t" else "" - in - let pname = prefix ^ name in + let spacer = if ctx.ctx_debug_level > 0 then " \t" else "" in + let pname = prefix ^ var.tcppv_name in ctx.ctx_output - (spacer ^ "\t" ^ tcpp_to_string vtype ^ " " ^ name ^ " = " ^ pname); + (spacer ^ "\t" ^ tcpp_to_string var.tcppv_type ^ " " ^ var.tcppv_name ^ " = " ^ pname); ctx.ctx_output (if not_null then ".Default(" ^ default_value_string ctx.ctx_common const ^ ");\n" else - ";\n" ^ spacer ^ "\tif (::hx::IsNull(" ^ pname ^ ")) " ^ name + ";\n" ^ spacer ^ "\tif (::hx::IsNull(" ^ pname ^ ")) " ^ var.tcppv_name ^ " = " ^ default_value_string ctx.ctx_common const ^ ";\n") | _ -> ()) args -let ctx_default_values ctx args prefix = cpp_gen_default_values ctx args prefix - let cpp_class_hash interface = gen_hash 0 (join_class_path interface.cl_path "::") @@ -399,14 +375,14 @@ let end_header_file output_h def_string = output_h ("\n#endif /* INCLUDED_" ^ def_string ^ " */ \n") let cpp_tfun_signature include_names args return_type = - let argList = print_tfun_arg_list include_names args in - let returnType = type_to_string return_type in + let argList = print_retyped_tfun_arg_list include_names args in + let returnType = tcpp_to_string return_type in "( " ^ returnType ^ " (::hx::Object::*)(" ^ argList ^ "))" 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 - | Some f -> Some f.tcf_field + | Some f -> Some f | None -> match def.tcl_super with | Some s -> find s @@ -414,8 +390,8 @@ let find_class_implementation func tcpp_class = in match find tcpp_class with - | Some { cf_type = TFun (args, ret) } -> - cpp_tfun_signature false args ret + | Some func -> + print_arg_list func.tcf_args "" | _ -> "" @@ -442,8 +418,7 @@ let needed_interface_functions implemented_instance_fields native_implementation |> List.fold_left iface_folder (have, []) |> snd -let gen_cpp_ast_expression_tree ctx class_name func_name function_args - function_type injection tree = +let gen_cpp_ast_expression_tree ctx class_name func_name function_args function_type injection tree = let writer = ctx.ctx_writer in let out = ctx.ctx_output in let lastLine = ref (-1) in @@ -523,24 +498,23 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | CppBreak -> out "break" | CppContinue -> out "continue" | CppGoto label -> out ("goto " ^ label_name label) - | CppVarDecl (var, init) -> ( - let name = cpp_var_name_of var in - (if cpp_no_debug_synbol ctx var then - out (cpp_var_type_of var ^ " " ^ name) - else - let dbgName = cpp_var_debug_name_of var in - let macro = if init = None then "HX_VAR" else "HX_VARI" in - let varType = cpp_macro_var_type_of var in - if name <> dbgName then - out - (macro ^ "_NAME( " ^ varType ^ "," ^ name ^ ",\"" ^ dbgName - ^ "\")") - else out (macro ^ "( " ^ varType ^ "," ^ name ^ ")")); - match init with - | Some init -> - out " = "; - gen init - | _ -> ()) + | CppVarDecl (var, init) -> + (if cpp_no_debug_synbol ctx var then + out (tcpp_to_string var.tcppv_type ^ " " ^ var.tcppv_name) + else + let dbgName = cpp_var_debug_name_of var.tcppv_var in + let macro = if init = None then "HX_VAR" else "HX_VARI" in + let varType = cpp_macro_var_type_of var in + if var.tcppv_name <> dbgName then + out + (macro ^ "_NAME( " ^ varType ^ "," ^ var.tcppv_name ^ ",\"" ^ dbgName + ^ "\")") + else out (macro ^ "( " ^ varType ^ "," ^ var.tcppv_name ^ ")")); + (match init with + | Some init -> + out " = "; + gen init + | _ -> ()) | CppEnumIndex obj -> gen obj; if cpp_is_dynamic_type obj.cpptype then @@ -669,6 +643,13 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | _ -> abort "Native static extensions must have at least 1 argument" expr.cpppos) + | FuncStatic (clazz, _, field) when is_marshalling_native_value_class clazz || is_marshalling_native_pointer clazz -> + let func_name = + match get_meta_string field.cf_meta Meta.Native with + | Some renamed -> renamed + | None -> cpp_member_name_of field + in + Printf.sprintf "%s::%s" (cpp_class_name clazz) func_name |> out | FuncStatic (clazz, _, field) -> ( match get_meta_string field.cf_meta Meta.Native with | Some rename -> @@ -719,15 +700,38 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args "::Array_obj< " ^ tcpp_to_string value ^ " >::__new" | TCppObjC klass -> cpp_class_path_of klass [] ^ "_obj::__new" | TCppNativePointer klass -> "new " ^ cpp_class_path_of klass [] + | TCppMarshalNativeType (value_type, Promoted) -> + closeCall := ")"; + let ptr, obj = get_extern_value_type_boxed value_type in + Printf.sprintf "%s( new %s " ptr obj + | TCppMarshalManagedType (cls, params) -> + let type_str, flags = build_type cls.cl_path cls.cl_pos params cls.cl_meta Meta.CppManagedType tcpp_to_string in + let standard_naming = List.exists (fun f -> f = "StandardNaming") flags in + let ptr = + if standard_naming then + type_str + else + Printf.sprintf "::hx::ObjectPtr< %s >" type_str + in + let obj = + if standard_naming then + type_str ^ "_obj" + else + type_str + in + closeCall := ")"; + Printf.sprintf "%s( new %s " ptr obj + | TCppMarshalNativeType (value_type, Stack) -> + newType |> tcpp_to_string | TCppInst (klass, p) when is_native_class klass -> cpp_class_path_of klass p | TCppInst (klass, p) -> cpp_class_path_of klass p ^ "_obj::__new" | TCppClass -> "::hx::Class_obj::__new" | TCppFunction _ -> tcpp_to_string newType | _ -> - abort - ("Unknown 'new' target " ^ tcpp_to_string newType) - expr.cpppos + abort + ("Unknown 'new' target " ^ tcpp_to_string newType) + expr.cpppos in out objName | FuncInternal (func, name, join) -> @@ -750,10 +754,18 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | CppNewNative e -> out "new "; gen e + | CppAddressOf ({ cpptype = TCppMarshalNativeType (_, Reference) } as e) -> + out "("; + gen e; + out ".ptr)" | CppAddressOf e -> out "&("; gen e; out ")" + | CppDereference ({ cpptype = TCppMarshalNativeType (_, Reference) } as e) -> + out "(*("; + gen e; + out ").ptr)" | CppDereference e -> out "(*("; gen e; @@ -773,6 +785,18 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args out ("->__Field(" ^ strq name ^ ",::hx::paccDynamic)") | CppArray arrayLoc -> ( match arrayLoc with + (* Special case for pointers to marshal type pointers *) + (* ::cpp::Pointer array access returns a T& but we want a T* for the marhsal pointer type reference *) + (* So do some manual pointer arithmatic *) + | ArrayPointer ({ cpptype = TCppPointer (_, TCppMarshalNativeType (Pointer _, _)) } as arrayObj, index) -> + gen arrayObj; + out ".ptr + "; + gen index + | ArrayRawPointer ({ cpptype = TCppRawPointer (_, TCppMarshalNativeType (Pointer _, _)) } as arrayObj, index) -> + gen arrayObj; + out " + "; + gen index + | ArrayTyped (arrayObj, index, _) -> gen arrayObj; out "->__get("; @@ -824,8 +848,8 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args in (match lvalue with | CppVarRef (VarClosure var) - when is_gc_element ctx (cpp_type_of var.v_type) -> - out ("this->_hx_set_" ^ cpp_var_name_of var ^ "(HX_CTX, "); + when is_gc_element ctx var.tcppv_type -> + out ("this->_hx_set_" ^ var.tcppv_name ^ "(HX_CTX, "); gen rvalue; out ")" | CppVarRef (VarThis (member, _)) @@ -843,7 +867,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args gen obj; out (operator ^ member) | CppVarRef varLoc -> - gen_val_loc varLoc true; + gen_val_loc varLoc; out " = "; gen rvalue | CppArrayRef arrayLoc -> ( @@ -932,7 +956,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args if native then out "null()" else if path = "::Array" then out "::hx::ArrayBase::__mClass" else out ("::hx::ClassOf< " ^ path ^ " >()") - | CppVar loc -> gen_val_loc loc false + | CppVar loc -> gen_val_loc loc | CppClosure closure -> out (" ::Dynamic(new _hx_Closure_" ^ string_of_int closure.close_id ^ "("); @@ -944,10 +968,11 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | _ -> ()); StringMap.iter - (fun name value -> + (fun _ var -> + let name = var.tcppv_name in out !separator; separator := ","; - out (keyword_remap name)) + out name) closure.close_undeclared; out "))" | CppObjectDecl (values, isStruct) -> @@ -1099,7 +1124,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args out ("->_hx_get" ^ baseType ^ "(" ^ string_of_int index ^ ")"); match valueType with | TCppObjectArray _ | TCppScalarArray _ | TCppDynamicArray | TCppClass - | TCppEnum _ | TCppInst _ -> + | TCppEnum _ | TCppInst _ | TCppMarshalManagedType _ -> out (".StaticCast< " ^ tcpp_to_string valueType ^ " >()") | _ -> ()) | CppIntSwitch (condition, cases, defVal) -> @@ -1192,15 +1217,15 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args gen block; out " : "; gen elze - | CppFor (tvar, init, loop) -> - let varType = cpp_var_type_of tvar in + | CppFor (var, init, loop) -> + let varType = tcpp_to_string var.tcppv_type in out ("for(::cpp::FastIterator_obj< " ^ varType ^ " > *__it = ::cpp::CreateFastIterator< " ^ varType ^ " >("); gen init; out "); __it->hasNext(); )"; let prologue _ = - output_i (varType ^ " " ^ cpp_var_name_of tvar ^ " = __it->next();\n") + output_i (varType ^ " " ^ var.tcppv_name ^ " = __it->next();\n") in gen_with_injection (mk_injection prologue "" "") loop true | CppTry (block, catches) -> @@ -1226,8 +1251,8 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args let else_str = ref "" in List.iter (fun (v, catch) -> - let type_name = cpp_var_type_of v in - (match cpp_type_of v.v_type with + let type_name = tcpp_to_string v.tcppv_type in + (match v.tcppv_type with | TCppInterface klass -> let hash = cpp_class_hash klass in output_i @@ -1250,7 +1275,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args | _ -> output_i "HX_STACK_BEGIN_CATCH\n"; output_i - (type_name ^ " " ^ cpp_var_name_of v ^ " = _hx_e;\n") + (type_name ^ " " ^ v.tcppv_name ^ " = _hx_e;\n") in gen_with_injection (mk_injection prologue "" "") catch true; else_str := "else ") @@ -1349,7 +1374,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args and gen expr = gen_with_injection None expr true and gen_lvalue lvalue = match lvalue with - | CppVarRef varLoc -> gen_val_loc varLoc true + | CppVarRef varLoc -> gen_val_loc varLoc | CppArrayRef arrayLoc -> ( match arrayLoc with | ArrayObject (arrayObj, index, _) -> @@ -1395,10 +1420,10 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args out "::hx::FieldRef(("; gen expr; out (")" ^ objPtr ^ "," ^ strq name ^ ")") - and gen_val_loc loc lvalue = + and gen_val_loc loc = match loc with - | VarClosure var -> out (cpp_var_name_of var) - | VarLocal local -> out (cpp_var_name_of local) + | VarClosure var + | VarLocal var -> out var.tcppv_name | VarStatic (clazz, objc, member) -> ( match get_meta_string member.cf_meta Meta.Native with | Some n -> out n @@ -1475,18 +1500,22 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args else "::hx::LocalFunc,"); out ("_hx_Closure_" ^ string_of_int closure.close_id); StringMap.iter - (fun name var -> - out ("," ^ cpp_macro_var_type_of var ^ "," ^ keyword_remap name)) + (fun _ var -> + let name = var.tcppv_name in + let str = cpp_macro_var_type_of var in + out ("," ^ str ^ "," ^ keyword_remap name)) closure.close_undeclared; out (") HXARGC(" ^ argsCount ^ ")\n"); - let func_type = tcpp_to_string closure.close_type in - output_i - (func_type ^ " _hx_run(" ^ cpp_arg_list closure.close_args "__o_" ^ ")"); + Printf.sprintf + "%s _hx_run( %s )" + (tcpp_to_string closure.close_type) + (print_arg_list closure.close_args "__o_") |> output_i; let prologue = function | gc_stack -> cpp_gen_default_values ctx closure.close_args "__o_"; + hx_stack_push ctx output_i class_name func_name closure.close_expr.cpppos gc_stack; if ctx.ctx_debug_level >= 2 then ( @@ -1495,8 +1524,7 @@ let gen_cpp_ast_expression_tree ctx class_name func_name function_args List.iter (fun (v, _) -> output_i - ("HX_STACK_ARG(" ^ cpp_var_name_of v ^ ",\"" - ^ cpp_debug_name_of v ^ "\")\n")) + ("HX_STACK_ARG(" ^ v.tcppv_name ^ ",\"" ^ v.tcppv_debug_name ^ "\")\n")) (List.filter (cpp_debug_var_visible ctx) closure.close_args); let line = Lexer.get_error_line closure.close_expr.cpppos in @@ -1525,8 +1553,7 @@ let gen_cpp_init ctx dot_name func_name var_name expr = hx_stack_push ctx output_i dot_name func_name expr.epos gc_stack in let injection = mk_injection prologue var_name "" in - gen_cpp_ast_expression_tree ctx dot_name func_name [] t_dynamic injection - (mk_block expr) + gen_cpp_ast_expression_tree ctx dot_name func_name [] TCppDynamic injection (mk_block expr) let generate_main_header output_main = output_main "#include \n\n"; @@ -1723,8 +1750,7 @@ let generate_files common_ctx file_info = files_file#close -let gen_cpp_function_body ctx clazz is_static func_name function_def head_code - tail_code no_debug = +let gen_cpp_function_body ctx clazz is_static func_name function_def head_code tail_code no_debug = let output = ctx.ctx_output in let dot_name = join_class_path clazz.cl_path "." in if no_debug then ctx.ctx_debug_level <- 0; @@ -1732,8 +1758,8 @@ let gen_cpp_function_body ctx clazz is_static func_name function_def head_code | gc_stack -> let spacer = if no_debug then "\t" else " \t" in let output_i s = output (spacer ^ s) in - ctx_default_values ctx function_def.tf_args "__o_"; - hx_stack_push ctx output_i dot_name func_name function_def.tf_expr.epos + cpp_gen_default_values ctx function_def.tcf_args "__o_"; + hx_stack_push ctx output_i dot_name func_name function_def.tcf_func.tf_expr.epos gc_stack; if ctx.ctx_debug_level >= 2 then ( if not is_static then @@ -1745,32 +1771,26 @@ let gen_cpp_function_body ctx clazz is_static func_name function_def head_code (fun (v, _) -> if not (cpp_no_debug_synbol ctx v) then output_i - ("HX_STACK_ARG(" ^ cpp_var_name_of v ^ ",\"" ^ v.v_name - ^ "\")\n")) - function_def.tf_args; + ("HX_STACK_ARG(" ^ v.tcppv_name ^ ",\"" ^ v.tcppv_debug_name ^ "\")\n")) + function_def.tcf_args; - let line = Lexer.get_error_line function_def.tf_expr.epos in + let line = Lexer.get_error_line function_def.tcf_func.tf_expr.epos in let lineName = Printf.sprintf "%4d" line in output ("HXLINE(" ^ lineName ^ ")\n")); if head_code <> "" then output_i (head_code ^ "\n") in - let args = List.map fst function_def.tf_args in let injection = mk_injection prologue "" tail_code in - gen_cpp_ast_expression_tree ctx dot_name func_name args function_def.tf_type - injection - (mk_block function_def.tf_expr) + gen_cpp_ast_expression_tree ctx dot_name func_name function_def.tcf_args function_def.tcf_return injection (mk_block function_def.tcf_func.tf_expr) -let constructor_arg_var_list class_def = - match class_def.cl_constructor with - | 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 -> +let constructor_arg_var_list tcpp_class = + match tcpp_class.tcl_constructor with + | Some constructor -> + List.map (fun (v, o) -> type_arg_to_string v o "__o_") constructor.tcf_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 tcpp_class isHeader = @@ -1778,7 +1798,7 @@ 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 cargs = constructor_arg_var_list tcpp_class.tcl_class in + let cargs = constructor_arg_var_list tcpp_class in let constructor_type_args = String.concat "," (List.map (fun (t, a) -> t ^ " " ^ a) cargs) @@ -1819,70 +1839,65 @@ let generate_constructor ctx out tcpp_class isHeader = dump_dynamic tcpp_class.tcl_class; if isHeader then - 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.tcl_class false "new" function_def "" "" - no_debug; - out "\n") + match tcpp_class.tcl_constructor with + | Some constructor -> + let cb no_debug = + ctx.ctx_real_this_ptr <- false; + gen_cpp_function_body ctx tcpp_class.tcl_class false "new" constructor "" "" no_debug; + out "\n"; + in + with_debug ctx constructor.tcf_field.cf_meta cb | _ -> () else out ("\t__this->__construct(" ^ constructor_args ^ ");\n"); out "\treturn __this;\n"; out "}\n\n") -let generate_native_constructor ctx out class_def isHeader = +let generate_native_constructor ctx out tcpp_class isHeader = let constructor_type_args = - class_def + tcpp_class |> 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 tcpp_class.tcl_constructor with + | Some constructor -> + if isHeader then + out ("\t\t" ^ tcpp_class.tcl_name ^ "(" ^ constructor_type_args ^ ");\n\n") + else + let cb no_debug = + ctx.ctx_real_this_ptr <- true; + out (tcpp_class.tcl_name ^ "::" ^ tcpp_class.tcl_name ^ "(" ^ constructor_type_args ^ ")"); + + (match tcpp_class.tcl_super with + | Some klass -> ( + let rec find_super_args = function + | TCall ({ eexpr = TConst TSuper }, args) :: _ -> Some args + | (TParenthesis e | TMeta (_, e) | TCast (e, None)) :: rest -> + find_super_args (e.eexpr :: rest) + | TBlock e :: rest -> + find_super_args (List.map (fun e -> e.eexpr) e @ rest) + | _ :: rest -> find_super_args rest + | _ -> None + in + match find_super_args [ constructor.tcf_func.tf_expr.eexpr ] with + | Some args -> + out ("\n:" ^ (cpp_class_path_of klass.tcl_class []) ^ "("); + let sep = ref "" in + List.iter + (fun arg -> + out !sep; + sep := ","; + gen_cpp_ast_expression_tree ctx "" "" [] TCppDynamic None + arg) + args; + out ")\n" + | _ -> ()) + | _ -> ()); - match class_def.cl_constructor with - | Some ({ cf_expr = Some { eexpr = TFunction function_def } } as definition) - -> - if isHeader then - out ("\t\t" ^ class_name ^ "(" ^ constructor_type_args ^ ");\n\n") - else - with_debug ctx definition.cf_meta (fun no_debug -> - ctx.ctx_real_this_ptr <- true; - out - (class_name ^ "::" ^ class_name ^ "(" ^ constructor_type_args - ^ ")"); - - (match class_def.cl_super with - | Some (klass, _) -> ( - let rec find_super_args = function - | TCall ({ eexpr = TConst TSuper }, args) :: _ -> Some args - | (TParenthesis e | TMeta (_, e) | TCast (e, None)) :: rest -> - find_super_args (e.eexpr :: rest) - | TBlock e :: rest -> - find_super_args (List.map (fun e -> e.eexpr) e @ rest) - | _ :: rest -> find_super_args rest - | _ -> None - in - match find_super_args [ function_def.tf_expr.eexpr ] with - | Some args -> - out ("\n:" ^ cpp_class_path_of klass [] ^ "("); - let sep = ref "" in - List.iter - (fun arg -> - out !sep; - sep := ","; - gen_cpp_ast_expression_tree ctx "" "" [] t_dynamic None - arg) - args; - out ")\n" - | _ -> ()) - | _ -> ()); - - let head_code = get_code definition.cf_meta Meta.FunctionCode in - 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 head_code = get_code constructor.tcf_field.cf_meta Meta.FunctionCode in + let tail_code = get_code constructor.tcf_field.cf_meta Meta.FunctionTailCode in + gen_cpp_function_body ctx tcpp_class.tcl_class false "new" constructor head_code tail_code no_debug + in + with_debug ctx constructor.tcf_field.cf_meta cb | _ -> () diff --git a/src/generators/cpp/gen/cppGenClassHeader.ml b/src/generators/cpp/gen/cppGenClassHeader.ml index dd9961b0d84..67e6c9644b6 100644 --- a/src/generators/cpp/gen/cppGenClassHeader.ml +++ b/src/generators/cpp/gen/cppGenClassHeader.ml @@ -9,12 +9,12 @@ open CppSourceWriter open CppContext open CppGen -let gen_member_variable ctx class_def is_static (var:tcpp_class_variable) = - let tcpp = cpp_type_of var.tcv_type in +let gen_member_variable ctx is_static var = + let tcpp = CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type var.tcv_type in let tcpp_str = tcpp_to_string tcpp in if not is_static && var.tcv_is_stackonly then - abort (Printf.sprintf "%s is marked as stack only and therefor cannot be used as the type for a non static variable" tcpp_str) var.tcv_field.cf_pos; + abort (Printf.sprintf "%s is marked as stack only and therefor cannot be used as the type for a non static variable" (Printer.s_type var.tcv_type)) var.tcv_field.cf_pos; let output = ctx.ctx_output in let suffix = if is_static then "\t\tstatic " else "\t\t" in @@ -56,9 +56,16 @@ let gen_member_function ctx class_def is_static func = |> 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 - Printf.sprintf "\t\t%s %s %s(%s);\n" attributes return_type_str func.tcf_name (print_arg_list func.tcf_func.tf_args "") |> output; + let return_type_str = + match cpp_type_of func.tcf_func.tf_type with + | TCppMarshalNativeType (value_type, (Reference | Promoted)) -> + TCppMarshalNativeType (value_type, Stack) |> tcpp_to_string + | TCppVoid -> + "void" + | other -> + tcpp_to_string other in + + Printf.sprintf "\t\t%s %s %s(%s);\n" attributes return_type_str func.tcf_name (print_arg_list func.tcf_args "") |> output; if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then Printf.sprintf "\t\t%s::Dynamic %s_dyn();\n" (if is_static then "static " else "") func.tcf_name |> output; @@ -156,7 +163,7 @@ let generate_native_header base_ctx tcpp_class = match class_def.cl_super with | Some (klass, params) -> let name = - tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params CppRetyper.with_stack_value_type) in ( name, name ) | None -> ("", "") @@ -166,12 +173,12 @@ let generate_native_header base_ctx tcpp_class = 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; + CppGen.generate_native_constructor ctx output_h tcpp_class true; if has_tcpp_class_flag tcpp_class Boot then output_h "\t\tstatic void __boot();\n"; tcpp_class.tcl_static_variables - |> List.iter (gen_member_variable ctx class_def true); + |> List.iter (gen_member_variable ctx true); tcpp_class.tcl_static_functions |> List.iter (gen_member_function ctx class_def true); @@ -180,7 +187,7 @@ let generate_native_header base_ctx tcpp_class = |> List.iter (gen_dynamic_function ctx class_def true); tcpp_class.tcl_variables - |> List.iter (gen_member_variable ctx class_def false); + |> List.iter (gen_member_variable ctx false); tcpp_class.tcl_functions |> List.iter (gen_member_function ctx class_def false); @@ -209,7 +216,7 @@ let generate_managed_header base_ctx tcpp_class = let gcName = gen_gc_name class_def.cl_path in let constructor_type_args = - tcpp_class.tcl_class + tcpp_class |> constructor_arg_var_list |> List.map (fun (t, a) -> Printf.sprintf "%s %s" t a) |> String.concat "," in @@ -221,7 +228,7 @@ let generate_managed_header base_ctx tcpp_class = let parent, super = match tcpp_class.tcl_super with | Some super -> - let name = tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params) in + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params CppRetyper.with_stack_value_type) in ( name, name ) | None -> ("::hx::Object", "::hx::Object") in @@ -304,13 +311,13 @@ let generate_managed_header base_ctx tcpp_class = 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 retVal = tcpp_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 + let argNames = print_arg_names func.iff_args in output_h - ("\t\t" ^ retVal ^ " " ^ func.iff_name ^ "( " ^ print_tfun_arg_list true func.iff_args ^ ") {\n"); + ("\t\t" ^ retVal ^ " " ^ func.iff_name ^ "( " ^ print_retyped_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")); + ("\t\t\t" ^ ret ^ "super::" ^ func.iff_name ^ "( " ^ argNames ^ ");\n\t\t}\n")); output_h "\n"); @@ -321,7 +328,7 @@ let generate_managed_header base_ctx tcpp_class = let alreadyGlued = Hashtbl.create 0 in List.iter (fun src -> - let rec check_interface (interface:tcpp_interface) = + let rec check_interface interface = let check_field func = let cast = cpp_tfun_signature false func.iff_args func.iff_return in let class_implementation = find_class_implementation func tcpp_class @@ -341,8 +348,8 @@ let generate_managed_header base_ctx tcpp_class = 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 argList = print_retyped_tfun_arg_list true func.iff_args in + let returnType = tcpp_to_string func.iff_return in let headerCode = "\t\t" ^ returnType ^ " " ^ glue ^ "(" ^ argList ^ ");\n" in output_h headerCode; output_h "\n") @@ -368,7 +375,7 @@ let generate_managed_header base_ctx tcpp_class = |> List.iter (gen_dynamic_function ctx class_def true); tcpp_class.tcl_static_variables - |> List.iter (gen_member_variable ctx class_def true); + |> List.iter (gen_member_variable ctx true); tcpp_class.tcl_functions |> List.iter (gen_member_function ctx class_def false); @@ -377,7 +384,7 @@ let generate_managed_header base_ctx tcpp_class = |> 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 (fun field -> gen_member_variable ctx false field); output_h (get_class_code class_def Meta.HeaderClassCode); output_h "};\n\n"; diff --git a/src/generators/cpp/gen/cppGenClassImplementation.ml b/src/generators/cpp/gen/cppGenClassImplementation.ml index de271c6a77d..f4a1841fe4b 100644 --- a/src/generators/cpp/gen/cppGenClassImplementation.ml +++ b/src/generators/cpp/gen/cppGenClassImplementation.ml @@ -1,6 +1,5 @@ open Ast open Type -open Error open Globals open CppStrings open CppTypeUtils @@ -11,22 +10,27 @@ open CppContext open CppGen let gen_function ctx class_def class_name is_static func = - let output = ctx.ctx_output in - let return_type_str = type_to_string func.tcf_func.tf_type in - let return_type = cpp_type_of func.tcf_func.tf_type in - let is_void = return_type = TCppVoid in - let ret = if is_void then "(void)" else "return " in + let output = ctx.ctx_output in + let return_type = cpp_type_of func.tcf_func.tf_type in + + let ret, is_void, return_type_str = + match return_type with + | TCppVoid -> + "(void)", true, "void" + | other -> + "return ", false, tcpp_to_string other in let needsWrapper t = match t with - | TCppStar _ -> true + | TCppStar _ + | TCppMarshalNativeType (_, (Stack | Promoted)) -> true | TCppInst (t, _) -> Meta.has Meta.StructAccess t.cl_meta | _ -> false in (* The actual function definition *) - output (if is_void then "void" else return_type_str); + output return_type_str; output (" " ^ class_name ^ "::" ^ func.tcf_name ^ "("); - output (print_arg_list func.tcf_func.tf_args "__o_"); + output (print_arg_list func.tcf_args "__o_"); output ")"; ctx.ctx_real_this_ptr <- true; let code = get_code func.tcf_field.cf_meta Meta.FunctionCode in @@ -37,20 +41,20 @@ let gen_function ctx class_def class_name is_static func = output " {\n"; output ("\t" ^ ret ^ "::" ^ nativeImpl ^ "(" - ^ print_arg_list_name func.tcf_func.tf_args "__o_" + ^ print_arg_list_name func.tcf_args "__o_" ^ ");\n"); output "}\n\n" | _ -> with_debug ctx func.tcf_field.cf_meta - (gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func.tcf_func code tail_code); + (gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func code tail_code); output "\n\n"; (* generate dynamic version too ... *) if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then - let tcpp_args = List.map (fun (v, _) -> cpp_type_of v.v_type) func.tcf_func.tf_args in + let tcpp_args = List.map (fun (v, _) -> CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type v.v_type) func.tcf_func.tf_args in let wrap = needsWrapper return_type || List.exists needsWrapper tcpp_args in if wrap then ( @@ -66,11 +70,14 @@ let gen_function ctx class_def class_name is_static func = 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 "); + | TCppStar _ -> + output "return (cpp::Pointer) " + | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta -> + output ("return (cpp::Struct< " ^ tcpp_to_string return_type ^ " >) ") + | TCppMarshalNativeType (value_type, _) -> + TCppMarshalNativeType (value_type, Reference) |> tcpp_to_string |> Printf.sprintf "return (%s) " |> output + | _ -> + output "return "); if is_static then output (class_name ^ "::" ^ func.tcf_name ^ "(") @@ -80,9 +87,11 @@ let gen_function ctx class_def class_name is_static func = let cast_prefix idx arg = match arg with | TCppStar (t, const) -> - Printf.sprintf "(::cpp::%sPointer< %s >) a%i" (if const then "Const" else "") (tcpp_to_string t) idx + Printf.sprintf "(::cpp::%sPointer< %s >) a%i" (if const then "Const" else "") (tcpp_to_string t) idx | TCppInst (t, _) when Meta.has Meta.StructAccess t.cl_meta -> Printf.sprintf "(::cpp::Struct< %s >) a%i" (tcpp_to_string arg) idx + | TCppMarshalNativeType (value_type, _) -> + Printf.sprintf "(%s) a%i" (TCppMarshalNativeType (value_type, Reference) |> tcpp_to_string) idx | _ -> Printf.sprintf "a%i" idx in @@ -109,28 +118,28 @@ let gen_function ctx class_def class_name is_static func = let prefix = if is_static then "STATIC_" else "" in Printf.sprintf "%sHX_DEFINE_DYNAMIC_FUNC%i(%s, %s, %s)\n\n" prefix (List.length func.tcf_func.tf_args) class_name func.tcf_name ret |> output -let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (func:tcpp_class_function) = +let gen_dynamic_function ctx class_def class_name is_static is_for_static_var func = let output = ctx.ctx_output in let func_name = "__default_" ^ func.tcf_name in let nargs = string_of_int (List.length func.tcf_func.tf_args) in - let return_type_str = type_to_string func.tcf_func.tf_type in - let return_type = cpp_type_of func.tcf_func.tf_type in + let return_type = CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type 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 func.tcf_func.tf_args "__o_") |> output; + Printf.sprintf "HX_BEGIN_DEFAULT_FUNC(%s, %s)\n" func_name class_name |> output; + Printf.sprintf "%s _hx_run(%s)" (tcpp_to_string return_type) (print_arg_list func.tcf_args "__o_") |> output; - gen_cpp_function_body ctx class_def is_static func_name func.tcf_func "" "" no_debug; + gen_cpp_function_body ctx class_def is_static func_name func "" "" no_debug; output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); output "HX_END_DEFAULT_FUNC\n\n" -let gen_static_variable ctx class_def class_name (var:tcpp_class_variable) = - let output = ctx.ctx_output in - Printf.sprintf "%s %s::%s;\n\n" (type_to_string var.tcv_type) class_name var.tcv_name |> output +let gen_static_variable ctx class_def class_name var = + let output = ctx.ctx_output in + let tcpp_str = var.tcv_type |> CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type |> tcpp_to_string in + Printf.sprintf "%s %s::%s;\n\n" tcpp_str class_name var.tcv_name |> output let gen_dynamic_function_init ctx class_def func = match func.tcf_field.cf_expr with @@ -139,14 +148,18 @@ let gen_dynamic_function_init ctx class_def func = | _ -> () -let gen_var_init ctx class_def var = - match var.tcv_field.cf_expr with - | Some 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 = if has_tcpp_class_flag tcpp_class Boot then ( + let gen_var_init ctx class_def var = + match var.tcv_field.cf_expr with + | Some expr -> + let dst = Builder.make_static_field class_def var.tcv_field var.tcv_field.cf_pos in + let op = Builder.binop OpAssign dst expr expr.etype expr.epos in + + gen_cpp_init ctx (join_class_path class_def.cl_path ".") "boot" "" op + | _ -> () + in + output_cpp ("void " ^ tcpp_class.tcl_name ^ "::__boot()\n{\n"); let dot_name = join_class_path tcpp_class.tcl_class.cl_path "." in @@ -274,7 +287,7 @@ let generate_native_class base_ctx tcpp_class = gen_dynamic_function_allocator ctx output_cpp tcpp_class; - generate_native_constructor ctx output_cpp class_def false; + generate_native_constructor ctx output_cpp tcpp_class false; gen_boot_field ctx output_cpp tcpp_class; end_namespace output_cpp class_path; @@ -296,7 +309,7 @@ let generate_managed_class base_ctx tcpp_class = let class_super_name = match class_def.cl_super with | Some (klass, params) -> - tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params CppRetyper.with_stack_value_type) | _ -> "" in @@ -323,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.tcl_name in - let cargs = constructor_arg_var_list class_def in + let cargs = constructor_arg_var_list tcpp_class in let constructor_var_list = List.map snd cargs in let constructor_type_args = cargs @@ -332,13 +345,14 @@ let generate_managed_class base_ctx tcpp_class = 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") + (match tcpp_class.tcl_constructor with + | Some constructor -> + let cb no_debug = + gen_cpp_function_body ctx class_def false "new" constructor "" "" + no_debug; + output_cpp "\n" + in + with_debug ctx constructor.tcf_field.cf_meta cb | _ -> output_cpp " { }\n\n"); (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *) @@ -420,8 +434,8 @@ let generate_managed_class base_ctx tcpp_class = 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 arg_list = print_retyped_tfun_arg_list true func.iff_args in + let return_type = tcpp_to_string func.iff_return in let return_str = if return_type = "void" then "" else "return " in let cpp_code = Printf.sprintf @@ -512,7 +526,7 @@ let generate_managed_class base_ctx tcpp_class = let rec find_next_super_iteration cls = match cls.tcl_super with | Some ({ tcl_container = Some Current } as super) -> - Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params)) + Some (tcpp_to_string_suffix "_obj" (cpp_instance_type super.tcl_class super.tcl_params CppRetyper.with_stack_value_type)) | Some super -> find_next_super_iteration super | None -> @@ -573,7 +587,7 @@ let generate_managed_class base_ctx tcpp_class = in let get_wrapper field value = - match cpp_type_of field.cf_type with + match CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type 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 _ -> @@ -618,11 +632,13 @@ let generate_managed_class base_ctx tcpp_class = in let castable f = - match cpp_type_of f.cf_type with + match CppRetyper.cpp_type_of CppRetyper.with_promoted_value_type 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 + "cpp::Struct< " ^ tcpp_to_string inst ^ " > " + | TCppStar (t, _) -> + "cpp::Pointer< " ^ tcpp_to_string t ^ " >" + | other -> + tcpp_to_string other in if has_tcpp_class_flag tcpp_class MemberGet then ( @@ -832,92 +848,110 @@ let generate_managed_class base_ctx tcpp_class = output_cpp "#endif\n\n"); let generate_script_function isStatic field scriptName callName = - match follow field.cf_type with - | TFun (args, return_type) when not (is_data_member field) -> - let isTemplated = not isStatic in - if isTemplated then output_cpp "\ntemplate"; - 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 isTemplated = not isStatic in + if isTemplated then output_cpp "\ntemplate"; + output_cpp + ("\nstatic void CPPIA_CALL " ^ scriptName + ^ "(::hx::CppiaCtx *ctx) {\n"); - let dump_call cast = - if isStatic then - output_cpp (class_name ^ "::" ^ callName ^ "(") - else - output_cpp - ("((" ^ class_name ^ "*)ctx->getThis())->" ^ cast ^ callName ^ "("); - - 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 - let signature = - if isTemplated then ( - output_cpp " _HX_SUPER ? "; - ignore (dump_call (class_name ^ "::")); - output_cpp " : "; - dump_call "") - else dump_call "" + let script_return_type = CppCppia.to_script_type field.tcf_return in + + (match field.tcf_return with + | TCppVoid -> + () + | TCppMarshalNativeType (native_type, _) -> + Printf.sprintf "ctx->return%s(%s(" (CppCppia.to_script_type_string script_return_type) (TCppMarshalNativeType (native_type, Reference) |> tcpp_to_string) |> output_cpp + | _ -> + Printf.sprintf "ctx->return%s(" (CppCppia.to_script_type_string script_return_type) |> output_cpp); + + let dump_call cast = + if isStatic then + Printf.sprintf "%s::%s(" class_name callName |> output_cpp + else + Printf.sprintf "((%s*)ctx->getThis())->%s%s(" class_name cast callName |> output_cpp; + + let folder (signature, sep, size) (var, expr) = + let script_type = + match CppCppia.to_script_type var.tcppv_type with + | (CppCppia.ScriptInt | CppCppia.ScriptFloat | CppCppia.ScriptBool) when expr <> None -> CppCppia.ScriptObject + | other -> other in + Printf.sprintf "%sctx->get%s(%s)" sep (CppCppia.to_script_type_string script_type) size |> output_cpp; + signature ^ CppCppia.to_script_type_signature script_type, + ",", + size ^ "+sizeof(" ^ CppCppia.to_script_type_size script_type ^ ")" + in + let signature, _, _ = + List.fold_left folder (CppCppia.to_script_type_signature script_return_type, "", "sizeof(void*)") field.tcf_args + in + output_cpp ")"; + signature + in + let signature = + if isTemplated then ( + output_cpp " _HX_SUPER ? "; + ignore (dump_call (class_name ^ "::")); + output_cpp " : "; + dump_call "") + else dump_call "" + in - if ret <> "v" then output_cpp ")"; - output_cpp ";\n}\n"; - signature - | _ -> "" + (match field.tcf_return with + | TCppVoid -> + () + | TCppMarshalNativeType (native_type, _) -> + output_cpp "))" + | _ -> + output_cpp ")"); + output_cpp ";\n}\n"; + signature in if scriptable then ( let dump_script_func idx func = - match func.tcf_field.cf_type with - | TFun (f_args, _) -> - let args = print_tfun_arg_list true f_args in - let return_type = type_to_string func.tcf_func.tf_type in - let ret = if return_type = "Void" || return_type = "void" then " " else "return " in - let vtable = Printf.sprintf "__scriptVTable[%i]" (idx + 1) in - - Printf.sprintf "\t%s %s(%s) {\n" return_type func.tcf_name args |> output_cpp; - Printf.sprintf ("\tif (%s) {\n") vtable |> output_cpp; - output_cpp "\t\t::hx::CppiaCtx *__ctx = ::hx::CppiaCtx::getCurrent();\n"; - output_cpp "\t\t::hx::AutoStack __as(__ctx);\n"; - output_cpp ("\t\t__ctx->pushObject( 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; + let args = print_arg_list func.tcf_args "" in + let return_type = tcpp_to_string func.tcf_return 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"); + + let wrap var = + match var.tcppv_type with + | TCppMarshalNativeType (native_type, _) -> + Printf.sprintf "%s(%s)" (tcpp_to_string (TCppMarshalNativeType (native_type, Reference))) var.tcppv_name + | _ -> + var.tcppv_name + in - output_cpp - ("\t\t" ^ ret ^ "__ctx->run" ^ CppCppia.script_type func.tcf_func.tf_type false ^ "(" ^ vtable ^ ");\n"); - output_cpp ("\t} else " ^ ret); + func.tcf_args + |> List.map + (fun (var, expr) -> + let script_type = + match CppCppia.to_script_type var.tcppv_type with + | (CppCppia.ScriptInt | CppCppia.ScriptFloat | CppCppia.ScriptBool) when expr <> None -> CppCppia.ScriptObject + | other -> other + in + Printf.sprintf "\t\t__ctx->push%s(%s);" (CppCppia.to_script_type_string script_type) (wrap var)) + |> String.concat "\n" + |> output_cpp; - let names = List.map (fun (n, _, _) -> keyword_remap n) f_args in + output_cpp "\n"; + output_cpp ("\t\t" ^ ret ^ "__ctx->run" ^ (func.tcf_return |> CppCppia.to_script_type |> CppCppia.to_script_type_string) ^ "(" ^ vtable ^ ");\n"); + output_cpp ("\t} else " ^ ret); - output_cpp - (class_name ^ "::" ^ func.tcf_name ^ "(" ^ String.concat "," names ^ ");"); + let names = List.map (fun (var, _) -> wrap var) func.tcf_args in + + output_cpp + (class_name ^ "::" ^ func.tcf_name ^ "(" ^ String.concat "," names ^ ");"); - if return_type <> "void" then output_cpp "return null();"; + if return_type <> "void" then output_cpp "return null();"; - output_cpp "}\n"; - | _ -> - abort "expected function type to be tfun" func.tcf_field.cf_pos + output_cpp "}\n" in let script_name = class_name ^ "__scriptable" in @@ -978,7 +1012,7 @@ 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.tcf_field ("__s_" ^ f.tcf_field.cf_name) f.tcf_name in + let signature = generate_script_function is_static f ("__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 @@ -1012,10 +1046,10 @@ let generate_managed_class base_ctx tcpp_class = (* 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 -> + match tcpp_class.tcl_constructor with + | Some f -> let signature = - generate_script_function false field "__script_construct_func" + generate_script_function false f "__script_construct_func" "__construct" in output_cpp diff --git a/src/generators/cpp/gen/cppGenEnum.ml b/src/generators/cpp/gen/cppGenEnum.ml index 0b75140b0a9..9a47c438ac9 100644 --- a/src/generators/cpp/gen/cppGenEnum.ml +++ b/src/generators/cpp/gen/cppGenEnum.ml @@ -12,17 +12,17 @@ let constructor_arg_count constructor = | _ -> 0 let gen_enum_constructor remap_class_name class_name output_cpp constructor = - match constructor.tef_field.ef_type with - | TFun (args, _) -> - Printf.sprintf "%s %s::%s(%s)\n" remap_class_name class_name constructor.tef_name (print_tfun_arg_list true args) |> output_cpp; + match constructor.tef_args with + | Some args -> + Printf.sprintf "%s %s::%s(%s)\n" remap_class_name class_name constructor.tef_name (print_retyped_tfun_arg_list true args) |> output_cpp; Printf.sprintf "{\n\treturn ::hx::CreateEnum<%s>(%s,%i,%i)" class_name constructor.tef_hash constructor.tef_field.ef_index (List.length args) |> output_cpp; args - |> List.mapi (fun i (arg, _, _) -> Printf.sprintf "->_hx_init(%i,%s)" i (keyword_remap arg)) + |> List.mapi (fun i arg -> Printf.sprintf "->_hx_init(%i,%s)" i arg.tfa_name) |> List.iter output_cpp; output_cpp ";\n}\n\n" - | _ -> + | None -> output_cpp ( remap_class_name ^ " " ^ class_name ^ "::" ^ constructor.tef_name ^ ";\n\n" ) let gen_static_reflection class_name output_cpp constructor = @@ -133,10 +133,10 @@ let generate base_ctx tcpp_enum = List.iter (fun constructor -> - match constructor.tef_field.ef_type with - | TFun (_,_) -> + match constructor.tef_args with + | Some _ -> () - | _ -> + | None -> 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; @@ -177,9 +177,9 @@ let generate base_ctx tcpp_enum = List.iter (fun constructor -> Printf.sprintf "\t\tstatic %s %s" remap_class_name constructor.tef_name |> output_h; - match constructor.tef_field.ef_type with - | TFun (args,_) -> - Printf.sprintf "(%s);\n" (print_tfun_arg_list true args) |> output_h; + match constructor.tef_args with + | Some args -> + Printf.sprintf "(%s);\n" (print_retyped_tfun_arg_list true args) |> output_h; Printf.sprintf "\t\tstatic ::Dynamic %s_dyn();\n" constructor.tef_name |> output_h; | _ -> output_h ";\n"; diff --git a/src/generators/cpp/gen/cppGenInterfaceHeader.ml b/src/generators/cpp/gen/cppGenInterfaceHeader.ml index 5013952be57..5f044085869 100644 --- a/src/generators/cpp/gen/cppGenInterfaceHeader.ml +++ b/src/generators/cpp/gen/cppGenInterfaceHeader.ml @@ -15,10 +15,10 @@ let attribs common_ctx = match Gctx.defined common_ctx Define.DllExport with let gen_native_function ctx interface func = let output = ctx.ctx_output in - let gen_args = print_tfun_arg_list true in + let gen_args = print_retyped_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; + Printf.sprintf "\t\tvirtual %s %s(%s)=0;\n" (tcpp_to_string func.iff_return) func.iff_name (gen_args func.iff_args) |> output; if reflective interface.if_class func.iff_field then if Gctx.defined ctx.ctx_common Define.DynamicInterfaceClosures then Printf.sprintf @@ -30,8 +30,13 @@ let gen_native_function ctx interface func = 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 argList = print_retyped_tfun_arg_list true func.iff_args in + let returnType = match func.iff_return with + | TCppMarshalNativeType (value_type, (Reference | Promoted)) -> + TCppMarshalNativeType (value_type, Stack) |> tcpp_to_string + | other -> + tcpp_to_string other + 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 @@ -103,7 +108,7 @@ let generate_native_interface base_ctx tcpp_interface = let parent, super = match tcpp_interface.if_class.cl_super with | Some (klass, params) -> - let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) in + let name = tcpp_to_string_suffix "_obj" (cpp_instance_type klass params CppRetyper.with_stack_value_type) in ( "virtual " ^ name, name ) | None -> ("virtual ::hx::NativeInterface", "::hx::NativeInterface") @@ -134,8 +139,6 @@ let generate_native_interface base_ctx tcpp_interface = output_h ("\t\ttypedef " ^ super ^ " super;\n"); output_h ("\t\ttypedef " ^ tcpp_interface.if_name ^ " OBJ_;\n"); - CppGen.generate_native_constructor ctx output_h tcpp_interface.if_class true; - gen_body tcpp_interface ctx output_h (gen_native_function ctx tcpp_interface); output_h "};\n\n"; @@ -152,7 +155,7 @@ let generate_managed_interface base_ctx tcpp_interface = let super = match tcpp_interface.if_class.cl_super with | Some (klass, params) -> - tcpp_to_string_suffix "_obj" (cpp_instance_type klass params) + tcpp_to_string_suffix "_obj" (cpp_instance_type klass params CppRetyper.with_stack_value_type) | None -> "::hx::Object" in diff --git a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml index 8d1c1a9ed5d..ef1ad8eadf9 100644 --- a/src/generators/cpp/gen/cppGenInterfaceImplementation.ml +++ b/src/generators/cpp/gen/cppGenInterfaceImplementation.ml @@ -31,35 +31,35 @@ let generate_protocol_delegate ctx protocol full_class_name functions output = output "}\n\n"; let dump_delegate func = - let retStr = type_to_string func.iff_return in + let retStr = tcpp_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) + | None -> (func.iff_name, List.map (fun a -> a.tfa_name) func.iff_args) in output ("- (" ^ retStr ^ ") " ^ fieldName); let first = ref true in (try List.iter2 - (fun (name, _, argType) signature_name -> + (fun arg signature_name -> if !first then - output (" :(" ^ type_to_string argType ^ ")" ^ name) + output (" :(" ^ tcpp_to_string arg.tfa_type ^ ")" ^ name) else output - (" " ^ signature_name ^ ":(" ^ type_to_string argType ^ ")" + (" " ^ signature_name ^ ":(" ^ tcpp_to_string arg.tfa_type ^ ")" ^ name); first := false) func.iff_args argNames with Invalid_argument _ -> abort (let argString = - String.concat "," (List.map (fun (name, _, _) -> name) func.iff_args) + String.concat "," (List.map (fun arg -> arg.tfa_name) func.iff_args) in - "Invalid arg count in delegate in " ^ func.iff_field.cf_name ^ " '" - ^ func.iff_field.cf_name ^ "," ^ argString ^ "' != '" + "Invalid arg count in delegate in " ^ func.iff_name ^ " '" + ^ func.iff_name ^ "," ^ argString ^ "' != '" ^ String.concat "," argNames ^ "'") func.iff_field.cf_pos); output " {\n"; @@ -69,7 +69,7 @@ let generate_protocol_delegate ctx protocol full_class_name functions output = ^ full_class_name ^ "::" ^ func.iff_name ^ "(haxeObj"); - List.iter (fun (name, _, _) -> output ("," ^ name)) func.iff_args; + List.iter (fun arg -> output ("," ^ arg.tfa_name)) func.iff_args; output ");\n}\n\n" in List.iter dump_delegate functions; @@ -134,8 +134,8 @@ let generate_managed_interface base_ctx tcpp_interface = if tcpp_interface.if_scriptable then ( let dump_script_field idx func = - let args = print_tfun_arg_list true func.iff_args in - let return_type = type_to_string func.iff_return in + let args = print_retyped_tfun_arg_list true func.iff_args in + let return_type = tcpp_to_string func.iff_return in let ret = if return_type = "Void" || return_type = "void" then " " else "return " in output_cpp ("\t" ^ return_type ^ " " ^ func.iff_name ^ "( " ^ args ^ " ) {\n"); @@ -143,14 +143,18 @@ let generate_managed_interface base_ctx tcpp_interface = output_cpp "\t\t::hx::AutoStack __as(__ctx);\n"; output_cpp "\t\t__ctx->pushObject(this);\n"; List.iter - (fun (name, opt, t) -> - output_cpp - ("\t\t__ctx->push" ^ CppCppia.script_type t opt ^ "(" ^ name ^ ");\n")) + (fun arg -> + let script_type = + match arg.tfa_type |> CppCppia.to_script_type with + | (CppCppia.ScriptInt | CppCppia.ScriptFloat | CppCppia.ScriptBool) when arg.tfa_optional -> CppCppia.ScriptObject + | other -> other + in + Printf.sprintf "\t\t__ctx->push%s(%s);\n" (CppCppia.to_script_type_string script_type) arg.tfa_name |> output_cpp) func.iff_args; let interfaceSlot = string_of_int (func.iff_script_slot |> Option.map (fun v -> -v) |> Option.default 0) in output_cpp ("\t\t" ^ ret ^ "__ctx->run" - ^ CppCppia.script_type func.iff_return false + ^ (func.iff_return |> CppCppia.to_script_type |> CppCppia.to_script_type_string) ^ "(__GetScriptVTable()[" ^ interfaceSlot ^ "]);\n"); output_cpp "\t}\n"; in @@ -167,27 +171,46 @@ let generate_managed_interface base_ctx tcpp_interface = 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 script_return_type = CppCppia.to_script_type func.iff_return in + + (match func.iff_return with + | TCppVoid -> + () + | TCppMarshalNativeType (native_type, _) -> + Printf.sprintf "ctx->return%s(%s(" (CppCppia.to_script_type_string script_return_type) (TCppMarshalNativeType (native_type, Reference) |> tcpp_to_string) |> output_cpp + | _ -> + Printf.sprintf "ctx->return%s(" (CppCppia.to_script_type_string script_return_type) |> output_cpp); let signature = output_cpp (tcpp_interface.if_name ^ "::" ^ func.iff_name ^ "(ctx->getThis()" ^ if List.length func.iff_args > 0 then "," else ""); + let folder (signature, sep, size) arg = + let script_type = + match arg.tfa_type |> CppCppia.to_script_type with + | (CppCppia.ScriptInt | CppCppia.ScriptFloat | CppCppia.ScriptBool) when arg.tfa_optional -> CppCppia.ScriptObject + | other -> other + in + Printf.sprintf "%sctx->get%s(%s)" sep (CppCppia.to_script_type_string script_type) size |> output_cpp; + signature ^ CppCppia.to_script_type_signature script_type, + ",", + size ^ "+sizeof(" ^ CppCppia.to_script_type_size script_type ^ ")" + in 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 + folder + (CppCppia.to_script_type_signature script_return_type, "", "sizeof(void*)") func.iff_args in output_cpp ")"; signature in - if ret <> "v" then output_cpp ")"; + (match func.iff_return with + | TCppVoid -> + () + | TCppMarshalNativeType (native_type, _) -> + output_cpp "))" + | _ -> + output_cpp ")"); output_cpp ";\n}\n"; (signature, func) in diff --git a/src/generators/cpp/gen/cppReferences.ml b/src/generators/cpp/gen/cppReferences.ml index 294a72febaa..d49ca1f69d7 100644 --- a/src/generators/cpp/gen/cppReferences.ml +++ b/src/generators/cpp/gen/cppReferences.ml @@ -70,6 +70,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade let add_extern_class klass = add_extern_type (TClassDecl klass) in let add_extern_enum enum = add_extern_type (TEnumDecl enum) in + let add_extern_abstract abstract = add_extern_type (TAbstractDecl abstract) in let add_native_gen_class klass = let include_files = get_all_meta_string_path klass.cl_meta @@ -87,9 +88,20 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade in let visited = ref [] in let rec visit_type in_type = + let rec find_base t = + match TFunctions.follow t with + | TAbstract (a, _) as t when is_scalar_abstract a -> + t + | TAbstract ({ a_extern = true } as a, _) as t when is_marshalling_native_enum a -> + t + | TAbstract (a, tl) -> + find_base (Abstract.get_underlying_type a tl) + | other -> + follow other + in if not (List.exists (fun t2 -> Type.fast_eq in_type t2) !visited) then ( visited := in_type :: !visited; - (match follow in_type with + (match find_base in_type with | TMono r -> ( match r.tm_type with None -> () | Some t -> visit_type t) | TEnum (enum, _) -> ( match is_extern_enum enum with @@ -116,8 +128,10 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade match klass.cl_kind with | KTypeParameter _ -> () | _ -> add_type klass.cl_path)) - | TAbstract (a, params) when is_scalar_abstract a -> - add_extern_type (TAbstractDecl a) + | TAbstract (a, _) when is_scalar_abstract a -> + add_extern_abstract a + | TAbstract ({ a_extern = true } as a, _) when is_marshalling_native_enum a -> + add_extern_abstract a | TFun (args, haxe_type) -> visit_type haxe_type; List.iter (fun (_, _, t) -> visit_type t) args @@ -171,7 +185,7 @@ let find_referenced_types_flags ctx obj filter super_deps constructor_deps heade | _ -> print_endline ("TSuper : Odd etype ?" - ^ (CppRetyper.cpp_type_of expression.etype |> tcpp_to_string))) + ^ (CppRetyper.cpp_type_of CppRetyper.with_reference_value_type expression.etype |> tcpp_to_string))) | _ -> ()); Type.iter visit_expression expression; visit_type (follow expression.etype) diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 1e813ce4d97..af65474fa54 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -280,6 +280,10 @@ let generate_source ctx = } in let folder acc cur = + let no_reference_meta pos = + abort "CPP0001: Marshalling type extern must be annotated with reference semantics" pos + in + (if not (Gctx.defined common_ctx Define.Objc) then match cur with | TClassDecl class_def when Meta.has Meta.Objc class_def.cl_meta -> @@ -287,7 +291,15 @@ let generate_source ctx = | _ -> ()); match cur with + | TAbstractDecl abs when is_marshalling_native_enum abs && not (ExtType.has_reference_semantics (TAbstract (abs, []))) -> + no_reference_meta abs.a_pos | TClassDecl class_def when is_extern_class class_def -> + if (is_marshalling_native_value_class class_def || is_marshalling_native_pointer class_def) && not (ExtType.has_reference_semantics (TInst (class_def, []))) then + no_reference_meta class_def.cl_pos; + + if is_marshalling_native_pointer class_def && class_def.cl_constructor |> Option.is_some then + abort "CPP0004: Pointer type cannot have a constructor" class_def.cl_pos; + 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