(* The Haxe Compiler Copyright (C) 2005-2019 Haxe Foundation This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) open Unix open ExtString open NativeLibraries open Common open Globals open Ast open JData (** Java lib *) module SS = Set.Make(String) type java_lib_ctx = { jcom : Common.context; (* current tparams context *) mutable jtparams : jtypes list; is_std : bool; } exception ConversionError of located let error s p = raise (ConversionError (located s p)) let is_haxe_keyword = function | "cast" | "extern" | "function" | "in" | "typedef" | "using" | "var" | "untyped" | "inline" -> true | _ -> false let jname_to_hx name = let name = if name <> "" && (String.get name 0 < 'A' || String.get name 0 > 'Z') then Char.escaped (Char.uppercase_ascii (String.get name 0)) ^ String.sub name 1 (String.length name - 1) else name in let name = String.concat "__" (String.nsplit name "_") in String.map (function | '$' -> '_' | c -> c) name let normalize_pack pack = List.map (function | "" -> "" | str when String.get str 0 >= 'A' && String.get str 0 <= 'Z' -> String.lowercase str | str -> str ) pack let jpath_to_hx (pack,name) = match pack, name with | ["haxe";"root"], name -> [], name | "com" :: ("oracle" | "sun") :: _, _ | "javax" :: _, _ | "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _ | "sun" :: _, _ | "sunw" :: _, _ -> "java" :: normalize_pack pack, jname_to_hx name | pack, name -> normalize_pack pack, jname_to_hx name let real_java_path ctx (pack,name) = s_type_path (pack, name) let lookup_jclass com path = let path = jpath_to_hx path in List.fold_right (fun java_lib acc -> match acc with | None -> java_lib#lookup path | Some p -> Some p ) com.native_libs.java_libs None let mk_type_path ctx path params = let name, sub = try let p, _ = String.split (snd path) "$" in jname_to_hx p, Some (jname_to_hx (snd path)) with | Invalid_string -> jname_to_hx (snd path), None in let pack = fst (jpath_to_hx path) in let pack, sub, name = match path with | [], ("Float" as c) | [], ("Int" as c) | [], ("Single" as c) | [], ("Bool" as c) | [], ("Dynamic" as c) | [], ("Iterator" as c) | [], ("ArrayAccess" as c) | [], ("Iterable" as c) -> [], Some c, "StdTypes" | [], ("String" as c) -> ["std"], None, c | _ -> pack, sub, name in CTPath { tpackage = pack; tname = name; tparams = params; tsub = sub; } let has_tparam name params = List.exists(fun (n,_,_) -> n = name) params let rec convert_arg ctx p arg = match arg with | TAny | TType (WSuper, _) -> TPType (mk_type_path ctx ([], "Dynamic") [],null_pos) | TType (_, jsig) -> TPType (convert_signature ctx p jsig,null_pos) and convert_signature ctx p jsig = match jsig with | TByte -> mk_type_path ctx (["java"; "types"], "Int8") [] | TChar -> mk_type_path ctx (["java"; "types"], "Char16") [] | TDouble -> mk_type_path ctx ([], "Float") [] | TFloat -> mk_type_path ctx ([], "Single") [] | TInt -> mk_type_path ctx ([], "Int") [] | TLong -> mk_type_path ctx (["haxe"], "Int64") [] | TShort -> mk_type_path ctx (["java"; "types"], "Int16") [] | TBool -> mk_type_path ctx ([], "Bool") [] | TObject ( (["haxe";"root"], name), args ) -> mk_type_path ctx ([], name) (List.map (convert_arg ctx p) args) (** nullable types *) (* replaced from Null to the actual abstract type to fix #2738 *) (* | TObject ( (["java";"lang"], "Integer"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Int") []) ] *) (* | TObject ( (["java";"lang"], "Double"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Float") []) ] *) (* | TObject ( (["java";"lang"], "Float"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Single") []) ] *) (* | TObject ( (["java";"lang"], "Boolean"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Bool") []) ] *) (* | TObject ( (["java";"lang"], "Byte"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int8") []) ] *) (* | TObject ( (["java";"lang"], "Character"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Char16") []) ] *) (* | TObject ( (["java";"lang"], "Short"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int16") []) ] *) (* | TObject ( (["java";"lang"], "Long"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["haxe"], "Int64") []) ] *) (** other std types *) | TObject ( (["java";"lang"], "Object"), [] ) -> mk_type_path ctx ([], "Dynamic") [] | TObject ( (["java";"lang"], "String"), [] ) -> mk_type_path ctx ([], "String") [] | TObject ( (["java";"lang"], "Enum"), [_] ) -> mk_type_path ctx ([], "EnumValue") [] (** other types *) | TObject ( path, [] ) -> (match lookup_jclass ctx.jcom path with | Some (jcl, _, _) -> mk_type_path ctx path (List.map (fun _ -> convert_arg ctx p TAny) jcl.ctypes) | None -> mk_type_path ctx path []) | TObject ( path, args ) -> mk_type_path ctx path (List.map (convert_arg ctx p) args) | TObjectInner (pack, (name, params) :: inners) -> let actual_param = match List.rev inners with | (_, p) :: _ -> p | _ -> die "" __LOC__ in mk_type_path ctx (pack, name ^ "$" ^ String.concat "$" (List.map fst inners)) (List.map (fun param -> convert_arg ctx p param) actual_param) | TObjectInner (pack, inners) -> die "" __LOC__ | TArray (jsig, _) -> mk_type_path ctx (["java"], "NativeArray") [ TPType (convert_signature ctx p jsig,null_pos) ] | TMethod _ -> JReader.error "TMethod cannot be converted directly into Complex Type" | TTypeParameter s -> (match ctx.jtparams with | cur :: others -> if has_tparam s cur then mk_type_path ctx ([], s) [] else begin if ctx.jcom.verbose && not(List.exists (has_tparam s) others) then print_endline ("Type parameter " ^ s ^ " was not found while building type!"); mk_type_path ctx ([], "Dynamic") [] end | _ -> if ctx.jcom.verbose then print_endline ("Empty type parameter stack!"); mk_type_path ctx ([], "Dynamic") []) let convert_constant ctx p const = Option.map_default (function | ConstString s -> Some (EConst (String(s,SDoubleQuotes)), p) | ConstInt i -> Some (EConst (Int (Printf.sprintf "%ld" i, None)), p) | ConstFloat f | ConstDouble f -> Some (EConst (Float (Printf.sprintf "%E" f, None)), p) | _ -> None) None const let convert_constraints ctx p tl = match tl with | [] -> None | [t] -> Some (convert_signature ctx p t,null_pos) | tl -> Some (CTIntersection(List.map (fun t -> convert_signature ctx p t,null_pos) tl),null_pos) let convert_param ctx p parent param = let name, constraints = match param with | (name, Some extends_sig, implem_sig) -> name, extends_sig :: implem_sig | (name, None, implemem_sig) -> name, implemem_sig in { tp_name = jname_to_hx name,null_pos; tp_params = []; tp_constraints = convert_constraints ctx p constraints; tp_default = None; tp_meta = []; } let get_type_path ctx ct = match ct with | CTPath p -> p | _ -> die "" __LOC__ let is_override field = List.exists (function | AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), _ ) }] -> true | _ -> false) field.jf_attributes let mk_override field = { field with jf_attributes = ((AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), [] ); ann_elements = [] }]) :: field.jf_attributes) } let del_override field = { field with jf_attributes = List.filter (fun a -> not (is_override_attrib a)) field.jf_attributes } let get_canonical ctx p pack name = (Meta.JavaCanonical, [EConst (String (String.concat "." pack,SDoubleQuotes)), p; EConst (String (name,SDoubleQuotes)), p], p) let show_in_completion ctx jc = if not ctx.is_std then true else match fst jc.cpath with | ("java" | "javax" | "org") :: _ -> true | _ -> false (** `haxe.Rest` auto-boxes primitive types. That means we can't use it as varargs for extern methods. E.g externs with `int` varargs are represented as `int[]` at run time while `haxe.Rest` is actually `java.lang.Integer[]`. *) let is_eligible_for_haxe_rest_args arg_type = match arg_type with | TByte | TChar | TDouble | TFloat | TInt | TLong | TShort | TBool -> false | _ -> true let convert_java_enum ctx p pe = let meta = ref (get_canonical ctx p (fst pe.cpath) (snd pe.cpath) :: [Meta.Native, [EConst (String (real_java_path ctx pe.cpath,SDoubleQuotes) ), p], p ]) in let data = ref [] in List.iter (fun f -> (* if List.mem JEnum f.jf_flags then *) match f.jf_vmsignature with | TObject( path, [] ) when path = pe.cpath && List.mem JStatic f.jf_flags && List.mem JFinal f.jf_flags -> data := { ec_name = f.jf_name,null_pos; ec_doc = None; ec_meta = []; ec_args = []; ec_pos = p; ec_params = []; ec_type = None; } :: !data; | _ -> () ) pe.cfields; if not (show_in_completion ctx pe) then meta := (Meta.NoCompletion,[],null_pos) :: !meta; EEnum { d_name = jname_to_hx (snd pe.cpath),null_pos; d_doc = None; d_params = []; (* enums never have type parameters *) d_meta = !meta; d_flags = [EExtern]; d_data = List.rev !data; } let convert_java_field ctx p jc is_interface field = let p = { p with pfile = p.pfile ^" (" ^field.jf_name ^")" } in let cff_doc = None in let cff_pos = p in let cff_meta = ref [] in let cff_access = ref [] in let cff_name = match field.jf_name with | "" -> "new" | ""-> raise Exit (* __init__ field *) | name when String.length name > 5 -> (match String.sub name 0 5 with | "__hx_" | "this$" -> raise Exit | _ -> name) | name -> name in let jf_constant = ref field.jf_constant in let readonly = ref false in let is_varargs = ref false in List.iter (function | JPublic -> cff_access := (APublic,null_pos) :: !cff_access | JPrivate -> raise Exit (* private instances aren't useful on externs *) | JProtected -> cff_meta := (Meta.Protected, [], p) :: !cff_meta; cff_access := (APrivate,null_pos) :: !cff_access | JStatic -> cff_access := (AStatic,null_pos) :: !cff_access | JFinal -> cff_access := (AFinal, p) :: !cff_access; (match field.jf_kind, field.jf_vmsignature, field.jf_constant with | JKField, TObject _, _ -> jf_constant := None | JKField, _, Some _ -> readonly := true; jf_constant := None; | _ -> jf_constant := None) (* | JSynchronized -> cff_meta := (Meta.Synchronized, [], p) :: !cff_meta *) | JVolatile -> cff_meta := (Meta.Volatile, [], p) :: !cff_meta | JTransient -> cff_meta := (Meta.Transient, [], p) :: !cff_meta | JVarArgs -> is_varargs := true | JAbstract when not is_interface -> cff_access := (AAbstract, p) :: !cff_access | _ -> () ) field.jf_flags; List.iter (function | AttrDeprecated when jc.cpath <> (["java";"util"],"Date") -> cff_meta := (Meta.Deprecated, [], p) :: !cff_meta (* TODO: pass anotations as @:meta *) | AttrVisibleAnnotations ann -> List.iter (function | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } -> cff_access := (AOverride,null_pos) :: !cff_access | _ -> () ) ann | _ -> () ) field.jf_attributes; List.iter (fun jsig -> match convert_signature ctx p jsig with | CTPath path -> cff_meta := (Meta.Throws, [Ast.EConst (Ast.String (s_type_path (path.tpackage,path.tname),SDoubleQuotes)), p],p) :: !cff_meta | _ -> () ) field.jf_throws; let extract_local_names () = let default i = "param" ^ string_of_int i in match field.jf_code with | None -> default | Some attribs -> try let rec loop attribs = match attribs with | AttrLocalVariableTable locals :: _ -> locals | _ :: attribs -> loop attribs | [] -> raise Not_found in let locals = loop attribs in let h = Hashtbl.create 0 in List.iter (fun local -> Hashtbl.replace h local.ld_index local.ld_name ) locals; (fun i -> try Hashtbl.find h (i - 1) (* they are 1-based *) with Not_found -> "param" ^ string_of_int i ) with Not_found -> default in let kind = match field.jf_kind with | JKField when !readonly -> FProp (("default",null_pos), ("null",null_pos), Some (convert_signature ctx p field.jf_signature,null_pos), None) | JKField -> FVar (Some (convert_signature ctx p field.jf_signature,null_pos), None) | JKMethod -> match field.jf_signature with | TMethod (args, ret) -> let local_names = extract_local_names() in let old_types = ctx.jtparams in (match ctx.jtparams with | c :: others -> ctx.jtparams <- (c @ field.jf_types) :: others | [] -> ctx.jtparams <- field.jf_types :: []); let i = ref 0 in let args_count = List.length args in let args = List.map (fun s -> incr i; let hx_sig = match s with | TArray (s1,_) when !is_varargs && !i = args_count && is_eligible_for_haxe_rest_args s1 -> mk_type_path ctx (["haxe"], "Rest") [TPType (convert_signature ctx p s1,null_pos)] | _ -> convert_signature ctx null_pos s in (local_names !i,null_pos), false, [], Some(hx_sig,null_pos), None ) args in let t = Option.map_default (convert_signature ctx p) (mk_type_path ctx ([], "Void") []) ret in cff_access := (AOverload,p) :: !cff_access; let types = List.map (function | (name, Some ext, impl) -> { tp_name = name,null_pos; tp_params = []; tp_constraints = convert_constraints ctx p (ext :: impl); tp_default = None; tp_meta = []; } | (name, None, impl) -> { tp_name = name,null_pos; tp_params = []; tp_constraints = convert_constraints ctx p impl; tp_default = None; tp_meta = []; } ) field.jf_types in ctx.jtparams <- old_types; FFun ({ f_params = types; f_args = args; f_type = Some (t,null_pos); f_expr = None }) | _ -> error "Method signature was expected" p in if field.jf_code <> None && is_interface then cff_meta := (Meta.JavaDefault,[],cff_pos) :: !cff_meta; let cff_name, cff_meta = match String.get cff_name 0 with | '%' -> let name = (String.sub cff_name 1 (String.length cff_name - 1)) in if not (is_haxe_keyword name) then cff_meta := (Meta.Deprecated, [EConst(String( "This static field `_" ^ name ^ "` is deprecated and will be removed in later versions. Please use `" ^ name ^ "` instead",SDoubleQuotes) ),p], p) :: !cff_meta; "_" ^ name, (Meta.Native, [EConst (String (name,SDoubleQuotes) ), cff_pos], cff_pos) :: !cff_meta | _ -> match String.nsplit cff_name "$" with | [ no_dollar ] -> cff_name, !cff_meta | parts -> String.concat "_" parts, (Meta.Native, [EConst (String (cff_name,SDoubleQuotes) ), cff_pos], cff_pos) :: !cff_meta in if Common.raw_defined ctx.jcom "java_loader_debug" then Printf.printf "\t%s%sfield %s : %s\n" (if List.mem_assoc AStatic !cff_access then "static " else "") (if List.mem_assoc AOverride !cff_access then "override " else "") cff_name (s_sig field.jf_signature); { cff_name = cff_name,null_pos; cff_doc = cff_doc; cff_pos = cff_pos; cff_meta = cff_meta; cff_access = !cff_access; cff_kind = kind } let rec japply_params params jsig = match params with | [] -> jsig | _ -> match jsig with | TTypeParameter s -> (try List.assoc s params with | Not_found -> jsig) | TObject(p,tl) -> TObject(p, args params tl) | TObjectInner(sl, stll) -> TObjectInner(sl, List.map (fun (s,tl) -> (s, args params tl)) stll) | TArray(s,io) -> TArray(japply_params params s, io) | TMethod(sl, sopt) -> TMethod(List.map (japply_params params) sl, Option.map (japply_params params) sopt) | _ -> jsig and args params tl = match params with | [] -> tl | _ -> List.map (function | TAny -> TAny | TType(w,s) -> TType(w,japply_params params s)) tl let mk_params jtypes = List.map (fun (s,_,_) -> (s,TTypeParameter s)) jtypes let convert_java_class ctx p jc = match List.mem JEnum jc.cflags with | true -> (* is enum *) [convert_java_enum ctx p jc] | false -> let flags = ref [HExtern] in if Common.raw_defined ctx.jcom "java_loader_debug" then begin let sup = jc.csuper :: jc.cinterfaces in print_endline ("converting " ^ (if List.mem JAbstract jc.cflags then "abstract " else "") ^ JData.path_s jc.cpath ^ " : " ^ (String.concat ", " (List.map s_sig sup))); end; (* todo: instead of JavaNative, use more specific definitions *) let meta = ref [Meta.JavaNative, [], p; Meta.Native, [EConst (String (real_java_path ctx jc.cpath,SDoubleQuotes) ), p], p; get_canonical ctx p (fst jc.cpath) (snd jc.cpath)] in let force_check = Common.defined ctx.jcom Define.ForceLibCheck in if not force_check then meta := (Meta.LibType,[],p) :: !meta; let is_interface = ref false in let is_abstract = ref false in List.iter (fun f -> match f with | JFinal -> flags := HFinal :: !flags | JInterface -> is_interface := true; flags := HInterface :: !flags | JAbstract -> meta := (Meta.Abstract, [], p) :: !meta; is_abstract := true; | JAnnotation -> meta := (Meta.Annotation, [], p) :: !meta | _ -> () ) jc.cflags; if !is_abstract && not !is_interface then flags := HAbstract :: !flags; (match jc.csuper with | TObject( (["java";"lang"], "Object"), _ ) -> () | TObject( (["haxe";"lang"], "HxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta | _ -> flags := HExtends (get_type_path ctx (convert_signature ctx p jc.csuper),null_pos) :: !flags ); List.iter (fun i -> match i with | TObject ( (["haxe";"lang"], "IHxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta | _ -> flags := if !is_interface then HExtends (get_type_path ctx (convert_signature ctx p i),null_pos) :: !flags else HImplements (get_type_path ctx (convert_signature ctx p i),null_pos) :: !flags ) jc.cinterfaces; let fields = ref [] in let jfields = ref [] in if jc.cpath <> (["java";"lang"], "CharSequence") then List.iter (fun f -> try if !is_interface && List.mem JStatic f.jf_flags then () else begin fields := convert_java_field ctx p jc !is_interface f :: !fields; jfields := f :: !jfields end with | Exit -> () ) (jc.cfields @ jc.cmethods); (* make sure the throws types are imported correctly *) let imports = List.concat (List.map (fun f -> List.map (fun jsig -> match convert_signature ctx p jsig with | CTPath path -> let pos = { p with pfile = p.pfile ^ " (" ^ f.jf_name ^" @:throws)" } in EImport( List.map (fun s -> s,pos) (path.tpackage @ [path.tname]), INormal ) | _ -> die "" __LOC__ ) f.jf_throws ) jc.cmethods) in if not (show_in_completion ctx jc) then meta := (Meta.NoCompletion,[],null_pos) :: !meta; (EClass { d_name = jname_to_hx (snd jc.cpath),null_pos; d_doc = None; d_params = List.map (convert_param ctx p jc.cpath) jc.ctypes; d_meta = !meta; d_flags = !flags; d_data = !fields; }) :: imports let create_ctx com is_std = { jcom = com; jtparams = []; is_std = is_std; } let rec has_type_param = function | TTypeParameter _ -> true | TMethod (lst, opt) -> List.exists has_type_param lst || Option.map_default has_type_param false opt | TArray (s,_) -> has_type_param s | TObjectInner (_, stpl) -> List.exists (fun (_,sigs) -> List.exists has_type_param_arg sigs) stpl | TObject(_, pl) -> List.exists has_type_param_arg pl | _ -> false and has_type_param_arg = function | TType(_,s) -> has_type_param s | _ -> false let rec japply_params jparams jsig = match jparams with | [] -> jsig | _ -> match jsig with | TObject(path,p) -> TObject(path, List.map (japply_params_tp jparams ) p) | TObjectInner(sl,stargl) -> TObjectInner(sl,List.map (fun (s,targ) -> (s, List.map (japply_params_tp jparams) targ)) stargl) | TArray(jsig,io) -> TArray(japply_params jparams jsig,io) | TMethod(args,ret) -> TMethod(List.map (japply_params jparams ) args, Option.map (japply_params jparams ) ret) | TTypeParameter s -> (try List.assoc s jparams with | Not_found -> jsig) | _ -> jsig and japply_params_tp jparams jtype_argument = match jtype_argument with | TAny -> TAny | TType(w,jsig) -> TType(w,japply_params jparams jsig) let mk_jparams jtypes params = match jtypes, params with | [], [] -> [] | _, [] -> List.map (fun (s,_,_) -> s, TObject( (["java";"lang"], "Object"), [] ) ) jtypes | _ -> List.map2 (fun (s,_,_) jt -> match jt with | TAny -> s, TObject((["java";"lang"],"Object"),[]) | TType(_,jsig) -> s, jsig) jtypes params let rec compatible_signature_arg ?arg_test f1 f2 = let arg_test = match arg_test with | None -> (fun _ _ -> true) | Some a -> a in if f1 = f2 then true else match f1, f2 with | TObject(p,a), TObject(p2,a2) -> p = p2 && arg_test a a2 | TObjectInner(sl, stal), TObjectInner(sl2, stal2) -> sl = sl2 && List.map fst stal = List.map fst stal2 | TArray(s,_) , TArray(s2,_) -> compatible_signature_arg s s2 | TTypeParameter t1 , TTypeParameter t2 -> t1 = t2 | _ -> false let rec compatible_param p1 p2 = match p1, p2 with | TType (_,s1), TType(_,s2) -> compatible_signature_arg ~arg_test:compatible_tparams s1 s2 | TAny, TType(_, TObject( (["java";"lang"],"Object"), _ )) -> true | TType(_, TObject( (["java";"lang"],"Object"), _ )), TAny -> true | _ -> false and compatible_tparams p1 p2 = try match p1, p2 with | [], [] -> true | _, [] -> let p2 = List.map (fun _ -> TAny) p1 in List.for_all2 compatible_param p1 p2 | [], _ -> let p1 = List.map (fun _ -> TAny) p2 in List.for_all2 compatible_param p1 p2 | _, _ -> List.for_all2 compatible_param p1 p2 with | Invalid_argument _ -> false let get_adapted_sig f f2 = match f.jf_types with | [] -> f.jf_signature | _ -> let jparams = mk_jparams f.jf_types (List.map (fun (s,_,_) -> TType(WNone, TTypeParameter s)) f2.jf_types) in japply_params jparams f.jf_signature let compatible_methods f1 f2 = if List.length f1.jf_types <> List.length f2.jf_types then false else match (get_adapted_sig f1 f2), f2.jf_signature with | TMethod(a1,_), TMethod(a2,_) when List.length a1 = List.length a2 -> List.for_all2 compatible_signature_arg a1 a2 | _ -> false let jcl_from_jsig com jsig = let path, params = match jsig with | TObject(path, params) -> path,params | TObjectInner(sl, stll) -> let last_params = ref [] in let real_path = sl, String.concat "$" (List.map (fun (s,p) -> last_params := p; s) stll) in real_path, !last_params | _ -> raise Not_found in match lookup_jclass com path with | None -> raise Not_found | Some(c,_,_) -> c,params let jclass_with_params com cls params = try match cls.ctypes with | [] -> cls | _ -> let jparams = mk_jparams cls.ctypes params in { cls with cfields = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cfields; cmethods = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cmethods; csuper = japply_params jparams cls.csuper; cinterfaces = List.map (japply_params jparams) cls.cinterfaces; } with Invalid_argument _ -> if com.verbose then print_endline ("Differing parameters for class: " ^ s_type_path cls.cpath); cls let is_object = function | TObject( (["java";"lang"], "Object"), [] ) -> true | _ -> false let is_tobject = function | TObject _ | TObjectInner _ -> true | _ -> false let simplify_args args = if List.for_all (function | TAny -> true | _ -> false) args then [] else args let compare_type com s1 s2 = if s1 = s2 then 0 else if not (is_tobject s1) then if is_tobject s2 then (* Dynamic *) 1 else if compatible_signature_arg s1 s2 then 0 else raise Exit else if not (is_tobject s2) then -1 else begin let rec loop ?(first_error=true) s1 s2 : bool = if is_object s1 then s1 = s2 else if compatible_signature_arg s1 s2 then begin let p1, p2 = match s1, s2 with | TObject(_, p1), TObject(_,p2) -> p1, p2 | TObjectInner(_, npl1), TObjectInner(_, npl2) -> snd (List.hd (List.rev npl1)), snd (List.hd (List.rev npl2)) | _ -> die "" __LOC__ (* not tobject *) in let p1, p2 = simplify_args p1, simplify_args p2 in let lp1 = List.length p1 in let lp2 = List.length p2 in if lp1 > lp2 then true else if lp2 > lp1 then false else begin (* if compatible tparams, it's fine *) if not (compatible_tparams p1 p2) then raise Exit; (* meaning: found, but incompatible type parameters *) true end end else try let c, p = jcl_from_jsig com s1 in let jparams = mk_jparams c.ctypes p in let super = japply_params jparams c.csuper in let implements = List.map (japply_params jparams) c.cinterfaces in loop ~first_error:first_error super s2 || List.exists (fun super -> loop ~first_error:first_error super s2) implements with | Not_found -> print_endline ("--java-lib: The type " ^ (s_sig s1) ^ " is referred but was not found. Compilation may not occur correctly."); print_endline "Did you forget to include a needed lib?"; if first_error then not (loop ~first_error:false s2 s1) else false in if loop s1 s2 then if loop s2 s1 then 0 else 1 else if loop s2 s1 then -1 else -2 end (* given a list of same overload functions, choose the best (or none) *) let select_best com flist = let rec loop cur_best = function | [] -> Some cur_best | f :: flist -> match get_adapted_sig f cur_best, cur_best.jf_signature with | TMethod(_,Some r), TMethod(_, Some r2) -> (try match compare_type com r r2 with | 0 -> (* same type - select any of them *) loop cur_best flist | 1 -> loop f flist | -1 -> loop cur_best flist | -2 -> (* error - no type is compatible *) if com.verbose then print_endline (f.jf_name ^ ": The types " ^ (s_sig r) ^ " and " ^ (s_sig r2) ^ " are incompatible"); (* bet that the current best has "beaten" other types *) loop cur_best flist | _ -> die "" __LOC__ with | Exit -> (* incompatible type parameters *) (* error mode *) if com.verbose then print_endline (f.jf_name ^ ": Incompatible argument return signatures: " ^ (s_sig r) ^ " and " ^ (s_sig r2)); None) | TMethod _, _ -> (* select the method *) loop f flist | _ -> loop cur_best flist in match loop (List.hd flist) (List.tl flist) with | Some f -> Some f | None -> match List.filter (fun f -> not (is_override f)) flist with (* error mode; take off all override methods *) | [] -> None | f :: [] -> Some f | f :: flist -> Some f (* pick one *) (**** begin normalize_jclass helpers ****) let fix_overrides_jclass com cls = let force_check = Common.defined com Define.ForceLibCheck in let methods = if force_check then List.map (fun f -> del_override f) cls.cmethods else cls.cmethods in let cmethods = methods in let super_fields = [] in let super_methods = [] in let nonstatics = List.filter (fun f -> not (List.mem JStatic f.jf_flags)) (cls.cfields @ cls.cmethods) in let is_pub = fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags in let cmethods, super_fields = if not (List.mem JInterface cls.cflags) then List.filter is_pub cmethods, List.filter is_pub super_fields else cmethods,super_fields in let rec loop cls super_methods super_fields cmethods nonstatics = try match cls.csuper with | TObject((["java";"lang"],"Object"),_) -> super_methods,super_fields,cmethods,nonstatics | _ -> let cls, params = jcl_from_jsig com cls.csuper in let cls = jclass_with_params com cls params in let nonstatics = (List.filter (fun f -> (List.mem JStatic f.jf_flags)) (cls.cfields @ cls.cmethods)) @ nonstatics in let super_methods = cls.cmethods @ super_methods in let super_fields = cls.cfields @ super_fields in let cmethods = if force_check then begin let overridden = ref [] in let cmethods = List.map (fun jm -> (* TODO rewrite/standardize empty spaces *) if not (is_override jm) && not (List.mem JStatic jm.jf_flags) && List.exists (fun msup -> let ret = msup.jf_name = jm.jf_name && not(List.mem JStatic msup.jf_flags) && compatible_methods msup jm in if ret then begin let f = mk_override msup in overridden := { f with jf_flags = jm.jf_flags } :: !overridden end; ret ) cls.cmethods then mk_override jm else jm ) cmethods in !overridden @ cmethods end else cmethods in loop cls super_methods super_fields cmethods nonstatics with | Not_found -> super_methods,super_fields,cmethods,nonstatics in loop cls super_methods super_fields cmethods nonstatics let normalize_jclass com cls = (* after adding the noCheck metadata, this option will annotate what changes were needed *) (* and that are now deprecated *) let force_check = Common.defined com Define.ForceLibCheck in (* fix overrides *) let super_methods, super_fields, cmethods, nonstatics = fix_overrides_jclass com cls in let all_methods = cmethods @ super_methods in (* look for interfaces and add missing implementations (may happen on abstracts or by vmsig differences *) (* (libType): even with libType enabled, we need to add these missing fields - otherwise we won't be able to use them from Haxe *) let added_interface_fields = ref [] in let rec loop_interface abstract cls iface = try match iface with | TObject ((["java";"lang"],"Object"), _) -> () | TObject (path,_) when path = cls.cpath -> () | _ -> let cif, params = jcl_from_jsig com iface in let cif = jclass_with_params com cif params in List.iter (fun jf -> if not(List.mem JStatic jf.jf_flags) && not (List.exists (fun jf2 -> jf.jf_name = jf2.jf_name && not (List.mem JStatic jf2.jf_flags) && jf.jf_signature = jf2.jf_signature) all_methods) then begin let jf = if abstract && force_check then del_override jf else jf in let jf = if not (List.mem JPublic jf.jf_flags) then { jf with jf_flags = JPublic :: jf.jf_flags } else jf in (* interfaces implementations are always public *) added_interface_fields := jf :: !added_interface_fields; end ) cif.cmethods; (* we don't need to loop again in the interface unless we are in an abstract class, since these interfaces are already normalized *) if abstract then List.iter (loop_interface abstract cif) cif.cinterfaces; with Not_found -> () in List.iter (loop_interface (List.mem JAbstract cls.cflags) cls) cls.cinterfaces; let nonstatics = !added_interface_fields @ nonstatics in let cmethods = !added_interface_fields @ cmethods in (* for each added field in the interface, lookup in super_methods possible methods to include *) (* so we can choose the better method still *) let cmethods = if not force_check then cmethods else List.fold_left (fun cmethods im -> (* see if any of the added_interface_fields need to be declared as override *) let f = List.find_all (fun jf -> jf.jf_name = im.jf_name && compatible_methods jf im) super_methods in let f = List.map mk_override f in f @ cmethods ) cmethods !added_interface_fields; in (* take off equals, hashCode and toString from interface *) let cmethods = if List.mem JInterface cls.cflags then List.filter (fun jf -> match jf.jf_name, jf.jf_vmsignature with | "equals", TMethod([TObject( (["java";"lang"],"Object"), _)],_) | "hashCode", TMethod([], _) | "toString", TMethod([], _) -> false | _ -> true ) cmethods else cmethods in (* change field name to not collide with haxe keywords and with static/non-static members *) let fold_field acc f = let change, both = match f.jf_name with | _ when List.mem JStatic f.jf_flags && List.exists (fun f2 -> f.jf_name = f2.jf_name) nonstatics -> true, true | _ -> is_haxe_keyword f.jf_name, false in let f2 = if change then { f with jf_name = "%" ^ f.jf_name } else f in if both then f :: f2 :: acc else f2 :: acc in (* change static fields that have the same name as methods *) let cfields = List.fold_left fold_field [] cls.cfields in let cmethods = List.fold_left fold_field [] cmethods in (* take off variable fields that have the same name as methods *) (* and take off variables that already have been declared *) let filter_field f f2 = f != f2 && (List.mem JStatic f.jf_flags = List.mem JStatic f2.jf_flags) && f.jf_name = f2.jf_name && f2.jf_kind <> f.jf_kind in let cfields = List.filter (fun f -> if List.mem JStatic f.jf_flags then not (List.exists (filter_field f) cmethods) else not (List.exists (filter_field f) nonstatics) && not (List.exists (fun f2 -> f != f2 && f.jf_name = f2.jf_name && not (List.mem JStatic f2.jf_flags)) super_fields) ) cfields in (* now filter any method that clashes with a field - on a superclass *) let cmethods = if force_check then List.filter (fun f -> if List.mem JStatic f.jf_flags then true else not (List.exists (filter_field f) super_fields) ) cmethods else cmethods in (* removing duplicate fields. They are there because of return type covariance in Java *) (* Also, if a method overrides a previous definition, and changes a type parameters' variance, *) (* we will take it off *) (* this means that some rare codes will never compile on Haxe, but unless Haxe adds variance support *) (* I can't see how this can be any different *) let rec loop acc = function | [] -> acc | f :: cmeths -> match List.partition (fun f2 -> f.jf_name = f2.jf_name && compatible_methods f f2) cmeths with | [], cmeths -> loop (f :: acc) cmeths | flist, cmeths -> match select_best com (f :: flist) with | None -> loop acc cmeths | Some f -> loop (f :: acc) cmeths in (* last pass: take off all cfields that are internal / private (they won't be accessible anyway) *) let cfields = List.filter(fun f -> List.exists (fun f -> f = JPublic || f = JProtected) f.jf_flags) cfields in let cmethods = loop [] cmethods in { cls with cfields = cfields; cmethods = cmethods } (**** end normalize_jclass helpers ****) let get_classes_zip zip = let ret = ref [] in List.iter (function | { Zip.is_directory = false; Zip.filename = f } when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" && not (String.exists f ~sub:"$") -> (match List.rev (String.nsplit f "/") with | clsname :: pack -> if not (String.contains clsname '$') then begin let path = jpath_to_hx (List.rev pack, String.sub clsname 0 (String.length clsname - 6)) in ret := path :: !ret end | _ -> ret := ([], jname_to_hx f) :: !ret) | _ -> () ) (Zip.entries zip); !ret class virtual java_library com name file_path = object(self) inherit [java_lib_type,unit] native_library name file_path as super val hxpack_to_jpack = Hashtbl.create 16 method convert_path (path : path) : path = Hashtbl.find hxpack_to_jpack path method private replace_canonical_name p pack name_original name_replace decl = let mk_meta name = (Meta.JavaCanonical, [EConst (String (String.concat "." pack,SDoubleQuotes)), p; EConst(String (name,SDoubleQuotes)), p], p) in let add_meta name metas = if Meta.has Meta.JavaCanonical metas then List.map (function | (Meta.JavaCanonical,[EConst (String(cpack,_)), _; EConst(String(cname,_)), _],_) -> let did_replace,name = String.replace ~str:cname ~sub:name_original ~by:name_replace in if not did_replace then print_endline (cname ^ " -> " ^ name_original ^ " -> " ^ name_replace); mk_meta name | m -> m ) metas else mk_meta name :: metas in match decl with | EClass c -> EClass { c with d_meta = add_meta (fst c.d_name) c.d_meta } | EEnum e -> EEnum { e with d_meta = add_meta (fst e.d_name) e.d_meta } | EAbstract a -> EAbstract { a with d_meta = add_meta (fst a.d_name) a.d_meta } | d -> d method build path (p : pos) : Ast.package option = let rec build ctx path p types = try if List.mem path !types then None else begin let first = match !types with | [ ["java";"lang"], "String" ] | [] -> true | p :: _ -> false in types := path :: !types; match self#lookup path, path with | None, ([], c) -> build ctx (["haxe";"root"], c) p types | None, _ -> None | Some (cls, real_path, pos_path), _ -> let is_disallowed_inner = first && String.exists (snd cls.cpath) ~sub:"$" in let is_disallowed_inner = if is_disallowed_inner then begin let outer, inner = String.split (snd cls.cpath) "$" in match self#lookup (fst path, outer) with | None -> false | _ -> true end else false in if is_disallowed_inner then None else begin if ctx.jcom.verbose then print_endline ("Parsed Java class " ^ (s_type_path cls.cpath)); let old_types = ctx.jtparams in ctx.jtparams <- cls.ctypes :: ctx.jtparams; let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in let ppath = self#convert_path path in let inner = List.fold_left (fun acc (path,out,_,_) -> let path = jpath_to_hx path in (if out <> Some ppath then acc else match build ctx path p types with | Some(_, classes) -> let base = snd ppath ^ "$" in (List.map (fun (def,p) -> self#replace_canonical_name p (fst ppath) base (snd ppath ^ ".") def, p) classes) @ acc | _ -> acc); ) [] cls.cinner_types in (* add _Statics class *) let inner = try if not (List.mem JInterface cls.cflags) then raise Not_found; let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in if not (smethods <> [] || sfields <> []) then raise Not_found; let obj = TObject( (["java";"lang"],"Object"), []) in let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in match ncls with | EClass c :: imports -> (EClass { c with d_name = (fst c.d_name ^ "_Statics"),snd c.d_name }, pos) :: inner @ List.map (fun i -> i,pos) imports | _ -> die "" __LOC__ with | Not_found -> inner in let inner_alias = ref SS.empty in List.iter (fun x -> match fst x with | EClass c -> inner_alias := SS.add (fst c.d_name) !inner_alias; | _ -> () ) inner; let alias_list = ref [] in List.iter (fun x -> match x with | (EClass c, pos) -> begin let parts = String.nsplit (fst c.d_name) "_24" in match parts with | _ :: _ -> let alias_name = String.concat "_" parts in if (not (SS.mem alias_name !inner_alias)) && (not (String.exists (snd path) ~sub:"_24")) then begin let alias_def = ETypedef { d_name = alias_name,null_pos; d_doc = None; d_params = c.d_params; d_meta = []; d_flags = []; d_data = CTPath { tpackage = pack; tname = snd path; tparams = List.map (fun tp -> TPType (CTPath { tpackage = []; tname = fst tp.tp_name; tparams = []; tsub = None; },null_pos) ) c.d_params; tsub = Some(fst c.d_name); },null_pos; } in inner_alias := SS.add alias_name !inner_alias; alias_list := (alias_def, pos) :: !alias_list; end | _ -> () end | _ -> () ) inner; let inner = List.concat [!alias_list ; inner] in let classes = List.map (fun t -> t,pos) (convert_java_class ctx pos cls) in let imports, defs = List.partition (function | (EImport(_),_) -> true | _ -> false) (classes @ inner) in let ret = Some (pack, imports @ defs) in ctx.jtparams <- old_types; ret end end with | JReader.Error_message msg -> print_endline ("Class reader failed: " ^ msg); None | e -> if ctx.jcom.verbose then begin (* print_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *) print_endline (Printexc.to_string e) end; None in build (create_ctx com (self#has_flag FlagIsStd)) path p (ref [["java";"lang"], "String"]) method get_data = () end class java_library_jar com name file_path = object(self) inherit java_library com name file_path val zip = lazy (Zip.open_in file_path) val mutable cached_files = None val cached_types = Hashtbl.create 12 val mutable loaded = false val mutable closed = false method load = if not loaded then begin loaded <- true; List.iter (function | { Zip.is_directory = false; Zip.filename = filename } when String.ends_with filename ~suffix:".class" -> let pack = String.nsplit filename "/" in (match List.rev pack with | [] -> () | name :: pack -> let name = String.sub name 0 (String.length name - 6) in let pack = List.rev pack in Hashtbl.add hxpack_to_jpack (jpath_to_hx (pack,name)) (pack,name)) | _ -> () ) (Zip.entries (Lazy.force zip)) end method private lookup' ((pack,name) : path) : java_lib_type = try let zip = Lazy.force zip in let location = (String.concat "/" (pack @ [name]) ^ ".class") in let entry = Zip.find_entry zip location in let data = Zip.read_entry zip entry in Some(JReader.parse_class (IO.input_string data), file_path, file_path ^ "@" ^ location) with | Not_found -> None method lookup (path : path) : java_lib_type = try Hashtbl.find cached_types path with | Not_found -> try self#load; let pack, name = self#convert_path path in let try_file (pack,name) = match self#lookup' (pack,name) with | None -> Hashtbl.add cached_types path None; None | Some (i, p1, p2) -> Hashtbl.add cached_types path (Some(i,p1,p2)); (* type loop normalization *) let ret = Some (normalize_jclass com i, p1, p2) in Hashtbl.replace cached_types path ret; ret in try_file (pack,name) with Not_found -> None method close = if not closed then begin closed <- true; Zip.close_in (Lazy.force zip) end method private list_modules' : path list = let ret = ref [] in List.iter (function | { Zip.is_directory = false; Zip.filename = f } when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" && not (String.exists f ~sub:"$") -> (match List.rev (String.nsplit f "/") with | clsname :: pack -> if not (String.contains clsname '$') then begin let path = jpath_to_hx (List.rev pack, String.sub clsname 0 (String.length clsname - 6)) in ret := path :: !ret end | _ -> ret := ([], jname_to_hx f) :: !ret) | _ -> () ) (Zip.entries (Lazy.force zip)); !ret method list_modules : path list = match cached_files with | None -> let ret = self#list_modules' in cached_files <- Some ret; ret | Some r -> r end class java_library_dir com name file_path = object(self) inherit java_library com name file_path val mutable files = [] method load = let all = ref [] in let rec iter_files pack dir path = try let file = Unix.readdir dir in let filepath = path ^ "/" ^ file in (if String.ends_with file ~suffix:".class" then let name = String.sub file 0 (String.length file - 6) in let path = jpath_to_hx (pack,name) in if not (String.exists file ~sub:"$") then all := path :: !all; Hashtbl.add hxpack_to_jpack path (pack,name) else if (Unix.stat filepath).st_kind = S_DIR && file <> "." && file <> ".." then let pack = pack @ [file] in iter_files (pack) (Unix.opendir filepath) filepath); iter_files pack dir path with | End_of_file | Unix.Unix_error _ -> Unix.closedir dir in iter_files [] (Unix.opendir file_path) file_path; files <- !all method close = () method list_modules = files method lookup (pack,name) : java_lib_type = let real_path = file_path ^ "/" ^ (String.concat "/" pack) ^ "/" ^ (name ^ ".class") in try let data = Std.input_file ~bin:true real_path in Some(JReader.parse_class (IO.input_string data), real_path, real_path) with | _ -> None end let add_java_lib com name std extern modern = let file = if Sys.file_exists name then name else try Common.find_file com name with | Not_found -> try Common.find_file com (name ^ ".jar") with | Not_found -> failwith ("Java lib " ^ name ^ " not found") in let java_lib = if modern then (new JavaModern.java_library_modern com name file :> (java_lib_type,unit) native_library) else match (Unix.stat file).st_kind with | S_DIR -> (new java_library_dir com name file :> (java_lib_type,unit) native_library) | _ -> (new java_library_jar com name file :> (java_lib_type,unit) native_library) in if std then java_lib#add_flag FlagIsStd; if extern then java_lib#add_flag FlagIsExtern; com.native_libs.java_libs <- (java_lib :> (java_lib_type,unit) native_library) :: com.native_libs.java_libs; CommonCache.handle_native_lib com java_lib let before_generate con = let java_ver = try int_of_string (Common.defined_value con Define.JavaVer) with | Not_found -> Common.define_value con Define.JavaVer "7"; 7 in if java_ver < 5 then failwith ("Java version is defined to target Java " ^ string_of_int java_ver ^ ", but the compiler can only output code to versions equal or superior to Java 5"); let rec loop i = Common.raw_define con ("java" ^ (string_of_int i)); if i > 0 then loop (i - 1) in loop java_ver