genjava.ml 72 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750
  1. (*
  2. * haXe/C# & Java Compiler
  3. * Copyright (c)2011 Cauê Waneck
  4. * based on and including code by (c)2005-2008 Nicolas Cannasse, Hugh Sanderson and Franco Ponticelli
  5. *
  6. * This program is free software; you can redistribute it and/or modify
  7. * it under the terms of the GNU General Public License as published by
  8. * the Free Software Foundation; either version 2 of the License, or
  9. * (at your option) any later version.
  10. *
  11. * This program is distributed in the hope that it will be useful,
  12. * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. * GNU General Public License for more details.
  15. *
  16. * You should have received a copy of the GNU General Public License
  17. * along with this program; if not, write to the Free Software
  18. * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  19. *)
  20. open Ast
  21. open Common
  22. open Gencommon
  23. open Gencommon.SourceWriter
  24. open Type
  25. open Printf
  26. open Option
  27. let is_boxed_type t = match follow t with
  28. | TInst ({ cl_path = (["java";"lang"], "Boolean") }, [])
  29. | TInst ({ cl_path = (["java";"lang"], "Double") }, [])
  30. | TInst ({ cl_path = (["java";"lang"], "Integer") }, [])
  31. | TInst ({ cl_path = (["java";"lang"], "Byte") }, [])
  32. | TInst ({ cl_path = (["java";"lang"], "Short") }, [])
  33. | TInst ({ cl_path = (["java";"lang"], "Character") }, [])
  34. | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> true
  35. | _ -> false
  36. let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with
  37. | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool
  38. | TInst ({ cl_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat
  39. | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint
  40. | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) -> tbyte
  41. | TInst ({ cl_path = (["java";"lang"], "Short") }, []) -> tshort
  42. | TInst ({ cl_path = (["java";"lang"], "Character") }, []) -> tchar
  43. | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> tfloat
  44. | _ -> assert false
  45. let rec t_has_type_param t = match follow t with
  46. | TInst({ cl_kind = KTypeParameter }, []) -> true
  47. | TEnum(_, params)
  48. | TInst(_, params) -> List.exists t_has_type_param params
  49. | TFun(f,ret) -> t_has_type_param ret || List.exists (fun (_,_,t) -> t_has_type_param t) f
  50. | _ -> false
  51. let rec t_has_type_param_shallow last t = match follow t with
  52. | TInst({ cl_kind = KTypeParameter }, []) -> true
  53. | TEnum(_, params)
  54. | TInst(_, params) when not last -> List.exists (t_has_type_param_shallow true) params
  55. | TFun(f,ret) when not last -> t_has_type_param_shallow true ret || List.exists (fun (_,_,t) -> t_has_type_param_shallow true t) f
  56. | _ -> false
  57. let is_java_basic_type t =
  58. match follow t with
  59. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  60. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  61. | TInst( { cl_path = ([], "Int") }, [] )
  62. | TInst( { cl_path = ([], "Float") }, [] )
  63. | TEnum( { e_path = ([], "Bool") }, [] ) ->
  64. true
  65. | _ -> false
  66. let is_bool t =
  67. match follow t with
  68. | TEnum( { e_path = ([], "Bool") }, [] ) ->
  69. true
  70. | _ -> false
  71. let is_int_float gen t =
  72. match follow (gen.greal_type t) with
  73. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  74. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  75. | TInst( { cl_path = ([], "Int") }, [] )
  76. | TInst( { cl_path = ([], "Float") }, [] ) ->
  77. true
  78. | _ -> false
  79. let parse_explicit_iface =
  80. let regex = Str.regexp "\\." in
  81. let parse_explicit_iface str =
  82. let split = Str.split regex str in
  83. let rec get_iface split pack =
  84. match split with
  85. | clname :: fn_name :: [] -> fn_name, (List.rev pack, clname)
  86. | pack_piece :: tl -> get_iface tl (pack_piece :: pack)
  87. | _ -> assert false
  88. in
  89. get_iface split []
  90. in parse_explicit_iface
  91. let is_string t =
  92. match follow t with
  93. | TInst( { cl_path = ([], "String") }, [] ) -> true
  94. | _ -> false
  95. (* ******************************************* *)
  96. (* JavaSpecificESynf *)
  97. (* ******************************************* *)
  98. (*
  99. Some Java-specific syntax filters that must run before ExpressionUnwrap
  100. dependencies:
  101. It must run before ExprUnwrap, as it may not return valid Expr/Statement expressions
  102. It must run before ClassInstance, as it will detect expressions that need unchanged TTypeExpr
  103. It must run after CastDetect, as it changes casts
  104. It must run after TryCatchWrapper, to change Std.is() calls inside there
  105. *)
  106. module JavaSpecificESynf =
  107. struct
  108. let name = "java_specific_e"
  109. let priority = solve_deps name [ DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter CastDetect.priority; DAfter TryCatchWrapper.priority ]
  110. let get_cl_from_t t =
  111. match follow t with
  112. | TInst(cl,_) -> cl
  113. | _ -> assert false
  114. let traverse gen runtime_cl =
  115. let basic = gen.gcon.basic in
  116. let float_cl = get_cl ( get_type gen (["java";"lang"], "Double")) in
  117. let is_var = alloc_var "__is__" t_dynamic in
  118. let block = ref [] in
  119. let rec run e =
  120. match e.eexpr with
  121. | TBlock bl ->
  122. let old_block = !block in
  123. block := [];
  124. List.iter (fun e -> let e = run e in block := e :: !block) bl;
  125. let ret = List.rev !block in
  126. block := old_block;
  127. { e with eexpr = TBlock(ret) }
  128. (* Math changes *)
  129. | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "NaN" ) ->
  130. mk_static_field_access_infer float_cl "NaN" e.epos []
  131. | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "NEGATIVE_INFINITY" ) ->
  132. mk_static_field_access_infer float_cl "NEGATIVE_INFINITY" e.epos []
  133. | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "POSITIVE_INFINITY" ) ->
  134. mk_static_field_access_infer float_cl "POSITIVE_INFINITY" e.epos []
  135. | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "isNaN" ) ->
  136. mk_static_field_access_infer float_cl "isNaN" e.epos []
  137. | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "floor" ) }, _)
  138. | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "round" ) }, _)
  139. | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "ceil" ) }, _) ->
  140. mk_cast basic.tint (Type.map_expr run e)
  141. | TCall( ( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "isFinite" ) } as efield ), [v]) ->
  142. { e with eexpr =
  143. TUnop(Ast.Not, Ast.Prefix, {
  144. e with eexpr = TCall( mk_static_field_access_infer float_cl "isInfinite" efield.epos [], [run v] )
  145. })
  146. }
  147. (* end of math changes *)
  148. (* Std.is() *)
  149. | TCall(
  150. { eexpr = TField( { eexpr = TTypeExpr ( TClassDecl ({ cl_path = ([], "Std") }) ) }, "is") },
  151. [ obj; { eexpr = TTypeExpr(md) } ]
  152. ) ->
  153. let mk_is obj md =
  154. { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [
  155. run obj;
  156. { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos }
  157. ] ) }
  158. in
  159. let obj = run obj in
  160. (match follow_module follow md with
  161. | TClassDecl({ cl_path = ([], "Float") }) ->
  162. {
  163. eexpr = TCall(
  164. mk_static_field_access_infer runtime_cl "isDouble" e.epos [],
  165. [ run obj ]
  166. );
  167. etype = basic.tbool;
  168. epos = e.epos
  169. }
  170. | TClassDecl{ cl_path = ([], "Int") } ->
  171. {
  172. eexpr = TCall(
  173. mk_static_field_access_infer runtime_cl "isInt" e.epos [],
  174. [ run obj ]
  175. );
  176. etype = basic.tbool;
  177. epos = e.epos
  178. }
  179. | _ ->
  180. mk_is obj md
  181. )
  182. (* end Std.is() *)
  183. | _ -> Type.map_expr run e
  184. in
  185. run
  186. let configure gen (mapping_func:texpr->texpr) =
  187. let map e = Some(mapping_func e) in
  188. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  189. end;;
  190. (* ******************************************* *)
  191. (* JavaSpecificSynf *)
  192. (* ******************************************* *)
  193. (*
  194. Some Java-specific syntax filters that can run after ExprUnwrap
  195. dependencies:
  196. Runs after ExprUnwarp
  197. *)
  198. module JavaSpecificSynf =
  199. struct
  200. let name = "java_specific"
  201. let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DBefore IntDivisionSynf.priority ]
  202. let java_hash s =
  203. let h = ref Int32.zero in
  204. let thirtyone = Int32.of_int 31 in
  205. for i = 0 to String.length s - 1 do
  206. h := Int32.add (Int32.mul thirtyone !h) (Int32.of_int (int_of_char (String.unsafe_get s i)));
  207. done;
  208. !h
  209. let rec is_final_return_expr is_switch e =
  210. let is_final_return_expr = is_final_return_expr is_switch in
  211. match e.eexpr with
  212. | TReturn _
  213. | TThrow _ -> true
  214. (* this is hack to not use 'break' on switch cases *)
  215. | TLocal { v_name = "__fallback__" } when is_switch -> true
  216. | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> true
  217. | TParenthesis p -> is_final_return_expr p
  218. | TBlock bl -> is_final_return_block is_switch bl
  219. | TSwitch (_, el_e_l, edef) ->
  220. List.for_all (fun (_,e) -> is_final_return_expr e) el_e_l && Option.map_default is_final_return_expr false edef
  221. | TMatch (_, _, il_vl_e_l, edef) ->
  222. List.for_all (fun (_,_,e) -> is_final_return_expr e)il_vl_e_l && Option.map_default is_final_return_expr false edef
  223. | TIf (_,eif, Some eelse) ->
  224. is_final_return_expr eif && is_final_return_expr eelse
  225. | TFor (_,_,e) ->
  226. is_final_return_expr e
  227. | TWhile (_,e,_) ->
  228. is_final_return_expr e
  229. | TFunction tf ->
  230. is_final_return_expr tf.tf_expr
  231. | TTry (e, ve_l) ->
  232. is_final_return_expr e && List.for_all (fun (_,e) -> is_final_return_expr e) ve_l
  233. | _ -> false
  234. and is_final_return_block is_switch el =
  235. match el with
  236. | [] -> false
  237. | final :: [] -> is_final_return_expr is_switch final
  238. | hd :: tl -> is_final_return_block is_switch tl
  239. let is_null e = match e.eexpr with | TConst(TNull) -> true | _ -> false
  240. let rec is_equatable gen t =
  241. match follow t with
  242. | TInst(cl,_) ->
  243. if cl.cl_path = (["haxe";"lang"], "IEquatable") then
  244. true
  245. else
  246. List.exists (fun (cl,p) -> is_equatable gen (TInst(cl,p))) cl.cl_implements
  247. || (match cl.cl_super with | Some(cl,p) -> is_equatable gen (TInst(cl,p)) | None -> false)
  248. | _ -> false
  249. (*
  250. Changing string switch
  251. will take an expression like
  252. switch(str)
  253. {
  254. case "a":
  255. case "b":
  256. }
  257. and modify it to:
  258. {
  259. var execute_def = true;
  260. switch(str.hashCode())
  261. {
  262. case (hashcode of a):
  263. if (str == "a")
  264. {
  265. execute_def = false;
  266. ..code here
  267. } //else if (str == otherVariableWithSameHashCode) {
  268. ...
  269. }
  270. ...
  271. }
  272. if (execute_def)
  273. {
  274. ..default code
  275. }
  276. }
  277. this might actually be slower in some cases than a if/else approach, but it scales well and as a bonus,
  278. hashCode in java are cached, so we only have the performance hit once to cache it.
  279. *)
  280. let change_string_switch gen eswitch e1 ecases edefault =
  281. let basic = gen.gcon.basic in
  282. let is_final_ret = is_final_return_expr false eswitch in
  283. let has_default = is_some edefault in
  284. let block = ref [] in
  285. let local = match e1.eexpr with
  286. | TLocal _ -> e1
  287. | _ ->
  288. let var = mk_temp gen "svar" e1.etype in
  289. let added = { e1 with eexpr = TVars([var, Some(e1)]); etype = basic.tvoid } in
  290. let local = mk_local var e1.epos in
  291. block := added :: !block;
  292. local
  293. in
  294. let execute_def_var = mk_temp gen "executeDef" gen.gcon.basic.tbool in
  295. let execute_def = mk_local execute_def_var e1.epos in
  296. let execute_def_set = { eexpr = TBinop(Ast.OpAssign, execute_def, { eexpr = TConst(TBool false); etype = basic.tbool; epos = e1.epos }); etype = basic.tbool; epos = e1.epos } in
  297. let hash_cache = ref None in
  298. let local_hashcode = ref { local with
  299. eexpr = TCall({ local with
  300. eexpr = TField(local, "hashCode");
  301. etype = TFun([], basic.tint);
  302. }, []);
  303. etype = basic.tint
  304. } in
  305. let get_hash_cache () =
  306. match !hash_cache with
  307. | Some c -> c
  308. | None ->
  309. let var = mk_temp gen "hash" basic.tint in
  310. let cond = !local_hashcode in
  311. block := { eexpr = TVars([var, Some cond]); etype = basic.tvoid; epos = local.epos } :: !block;
  312. let local = mk_local var local.epos in
  313. local_hashcode := local;
  314. hash_cache := Some local;
  315. local
  316. in
  317. let has_case = ref false in
  318. (* first we need to reorder all cases so all collisions are close to each other *)
  319. let get_str e = match e.eexpr with | TConst(TString s) -> s | _ -> assert false in
  320. let has_conflict = ref false in
  321. let rec reorder_cases unordered ordered =
  322. match unordered with
  323. | [] -> ordered
  324. | (el, e) :: tl ->
  325. let current = Hashtbl.create 1 in
  326. List.iter (fun e ->
  327. let str = get_str e in
  328. let hash = java_hash str in
  329. Hashtbl.add current hash true
  330. ) el;
  331. let rec extract_fields cases found_cases ret_cases =
  332. match cases with
  333. | [] -> found_cases, ret_cases
  334. | (el, e) :: tl ->
  335. if List.exists (fun e -> Hashtbl.mem current (java_hash (get_str e)) ) el then begin
  336. has_conflict := true;
  337. List.iter (fun e -> Hashtbl.add current (java_hash (get_str e)) true) el;
  338. extract_fields tl ( (el, e) :: found_cases ) ret_cases
  339. end else
  340. extract_fields tl found_cases ( (el, e) :: ret_cases )
  341. in
  342. let found, remaining = extract_fields tl [] [] in
  343. let ret = if found <> [] then
  344. let ret = List.sort (fun (e1,_) (e2,_) -> compare (List.length e2) (List.length e1) ) ( (el, e) :: found ) in
  345. let rec loop ret acc =
  346. match ret with
  347. | (el, e) :: ( (_,_) :: _ as tl ) -> loop tl ( (true, el, e) :: acc )
  348. | (el, e) :: [] -> ( (false, el, e) :: acc )
  349. | _ -> assert false
  350. in
  351. List.rev (loop ret [])
  352. else
  353. (false, el, e) :: []
  354. in
  355. reorder_cases remaining (ordered @ ret)
  356. in
  357. let already_in_cases = Hashtbl.create 0 in
  358. let change_case (has_fallback, el, e) =
  359. let conds, el = List.fold_left (fun (conds,el) e ->
  360. has_case := true;
  361. match e.eexpr with
  362. | TConst(TString s) ->
  363. let hashed = java_hash s in
  364. let equals_test = {
  365. eexpr = TCall({ e with eexpr = TField(local, "equals"); etype = TFun(["obj",false,t_dynamic],basic.tbool) }, [ e ]);
  366. etype = basic.tbool;
  367. epos = e.epos
  368. } in
  369. let hashed_expr = { eexpr = TConst(TInt hashed); etype = basic.tint; epos = e.epos } in
  370. let hashed_exprs = if !has_conflict then begin
  371. if Hashtbl.mem already_in_cases hashed then
  372. el
  373. else begin
  374. Hashtbl.add already_in_cases hashed true;
  375. hashed_expr :: el
  376. end
  377. end else hashed_expr :: el in
  378. let conds = match conds with
  379. | None -> equals_test
  380. | Some c ->
  381. (*
  382. if there is more than one case, we should test first if hash equals to the one specified.
  383. This way we can save a heavier string compare
  384. *)
  385. let equals_test = mk_paren {
  386. eexpr = TBinop(Ast.OpBoolAnd, { eexpr = TBinop(Ast.OpEq, get_hash_cache(), hashed_expr); etype = basic.tbool; epos = e.epos }, equals_test);
  387. etype = basic.tbool;
  388. epos = e.epos;
  389. } in
  390. { eexpr = TBinop(Ast.OpBoolOr, equals_test, c); etype = basic.tbool; epos = e1.epos }
  391. in
  392. Some conds, hashed_exprs
  393. | _ -> assert false
  394. ) (None,[]) el in
  395. let e = if has_default then Codegen.concat execute_def_set e else e in
  396. let e = if !has_conflict then Codegen.concat e { e with eexpr = TBreak; etype = basic.tvoid } else e in
  397. let e = {
  398. eexpr = TIf(get conds, e, None);
  399. etype = basic.tvoid;
  400. epos = e.epos
  401. } in
  402. let e = if has_fallback then { e with eexpr = TBlock([ e; mk_local (alloc_var "__fallback__" t_dynamic) e.epos]) } else e in
  403. (el, e)
  404. in
  405. let switch = { eswitch with
  406. eexpr = TSwitch(!local_hashcode, List.map change_case (reorder_cases ecases []), None);
  407. } in
  408. (if !has_case then begin
  409. (if has_default then block := { e1 with eexpr = TVars([execute_def_var, Some({ e1 with eexpr = TConst(TBool true); etype = basic.tbool })]); etype = basic.tvoid } :: !block);
  410. block := switch :: !block
  411. end);
  412. (match edefault with
  413. | None -> ()
  414. | Some edef when not !has_case ->
  415. block := edef :: !block
  416. | Some edef ->
  417. let eelse = if is_final_ret then Some { eexpr = TThrow { eexpr = TConst(TNull); etype = t_dynamic; epos = edef.epos }; etype = basic.tvoid; epos = edef.epos } else None in
  418. block := { edef with eexpr = TIf(execute_def, edef, eelse); etype = basic.tvoid } :: !block
  419. );
  420. { eswitch with eexpr = TBlock(List.rev !block) }
  421. let get_cl_from_t t =
  422. match follow t with
  423. | TInst(cl,_) -> cl
  424. | _ -> assert false
  425. let traverse gen runtime_cl =
  426. let basic = gen.gcon.basic in
  427. let tchar = match ( get_type gen (["java"], "Char16") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  428. let tbyte = match ( get_type gen (["java"], "Int8") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  429. let tshort = match ( get_type gen (["java"], "Int16") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  430. let tsingle = match ( get_type gen ([], "Single") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  431. let bool_cl = get_cl ( get_type gen (["java";"lang"], "Boolean")) in
  432. let string_ext = get_cl ( get_type gen (["haxe";"lang"], "StringExt")) in
  433. let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false in
  434. let rec run e =
  435. match e.eexpr with
  436. (* for new NativeArray<T> issues *)
  437. | TNew(({ cl_path = (["java"], "NativeArray") } as cl), [t], el) when t_has_type_param t ->
  438. mk_cast (TInst(cl,[t])) (mk_cast t_dynamic ({ e with eexpr = TNew(cl, [t_empty], List.map run el) }))
  439. (* Std.int() *)
  440. | TCall(
  441. { eexpr = TField( { eexpr = TTypeExpr ( TClassDecl ({ cl_path = ([], "Std") }) ) }, "int") },
  442. [obj]
  443. ) ->
  444. run (mk_cast basic.tint obj)
  445. (* end Std.int() *)
  446. | TField( ef, "length" ) when is_string ef.etype ->
  447. { e with eexpr = TCall(Type.map_expr run e, []) }
  448. | TCall( ( { eexpr = TField({ eexpr = TTypeExpr (TTypeDecl t) }, "fromCharCode") } ), [cc] ) when is_string (follow (TType(t,List.map snd t.t_types))) ->
  449. { e with eexpr = TNew(get_cl_from_t basic.tstring, [], [mk_cast tchar cc; mk_int gen 1 cc.epos]) }
  450. | TCall( ( { eexpr = TField(ef, ("charAt" as field)) } ), args )
  451. | TCall( ( { eexpr = TField(ef, ("charCodeAt" as field)) } ), args )
  452. | TCall( ( { eexpr = TField(ef, ("split" as field)) } ), args )
  453. | TCall( ( { eexpr = TField(ef, ("indexOf" as field)) } ), args )
  454. | TCall( ( { eexpr = TField(ef, ("lastIndexOf" as field)) } ), args )
  455. | TCall( ( { eexpr = TField(ef, ("substr" as field)) } ), args ) when is_string ef.etype ->
  456. { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) }
  457. | TCast(expr, m) when is_boxed_type e.etype ->
  458. (* let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with *)
  459. run { e with etype = unboxed_type gen e.etype tbyte tshort tchar tsingle }
  460. | TCast(expr, m) when is_bool e.etype ->
  461. { e with eexpr = TCast(mk_cast (TInst(bool_cl, [])) (run expr), m) }
  462. | TCast(expr, _) when is_int_float gen e.etype && not (is_int_float gen expr.etype) ->
  463. let needs_cast = match gen.gfollow#run_f e.etype with
  464. | TInst _ -> false
  465. | _ -> true
  466. in
  467. let fun_name = match follow e.etype with
  468. | TInst ({ cl_path = ([], "Float") },[]) -> "toDouble"
  469. | _ -> "toInt"
  470. in
  471. let ret = {
  472. eexpr = TCall(
  473. mk_static_field_access_infer runtime_cl fun_name expr.epos [],
  474. [ run expr ]
  475. );
  476. etype = if fun_name = "toDouble" then basic.tfloat else basic.tint;
  477. epos = expr.epos
  478. } in
  479. if needs_cast then mk_cast e.etype ret else ret
  480. (*| TCast(expr, c) when is_int_float gen e.etype ->
  481. (* cases when float x = (float) (java.lang.Double val); *)
  482. (* FIXME: this fix is broken since it will fail on cases where float x = (float) (java.lang.Float val) or similar. FIX THIS *)
  483. let need_second_cast = match gen.gfollow#run_f e.etype with
  484. | TInst _ -> false
  485. | _ -> true
  486. in
  487. if need_second_cast then { e with eexpr = TCast(mk_cast (follow e.etype) (run expr), c) } else Type.map_expr run e*)
  488. | TCast(expr, _) when is_string e.etype ->
  489. (*{ e with eexpr = TCall( { expr with eexpr = TField(expr, "ToString"); etype = TFun([], basic.tstring) }, [] ) }*)
  490. mk_paren { e with eexpr = TBinop(Ast.OpAdd, run expr, { e with eexpr = TConst(TString("")) }) }
  491. | TSwitch(cond, ecases, edefault) when is_string cond.etype ->
  492. (*let change_string_switch gen eswitch e1 ecases edefault =*)
  493. change_string_switch gen e (run cond) (List.map (fun (el,e) -> (el, run e)) ecases) (Option.map run edefault)
  494. | TBinop( (Ast.OpNotEq as op), e1, e2)
  495. | TBinop( (Ast.OpEq as op), e1, e2) when not (is_null e2 || is_null e1) && (is_string e1.etype || is_string e2.etype || is_equatable gen e1.etype || is_equatable gen e2.etype) ->
  496. let static = mk_static_field_access_infer (runtime_cl) "valEq" e1.epos [] in
  497. let eret = { eexpr = TCall(static, [run e1; run e2]); etype = gen.gcon.basic.tbool; epos=e.epos } in
  498. if op = Ast.OpNotEq then { eret with eexpr = TUnop(Ast.Not, Ast.Prefix, eret) } else eret
  499. | _ -> Type.map_expr run e
  500. in
  501. run
  502. let configure gen (mapping_func:texpr->texpr) =
  503. (if java_hash "Testing string hashCode implementation from haXe" <> (Int32.of_int 545883604) then assert false);
  504. let map e = Some(mapping_func e) in
  505. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  506. end;;
  507. let connecting_string = "?" (* ? see list here http://www.fileformat.info/info/unicode/category/index.htm and here for C# http://msdn.microsoft.com/en-us/library/aa664670.aspx *)
  508. let default_package = "java" (* I'm having this separated as I'm still not happy with having a cs package. Maybe dotnet would be better? *)
  509. let strict_mode = ref false (* strict mode is so we can check for unexpected information *)
  510. (* reserved c# words *)
  511. let reserved = let res = Hashtbl.create 120 in
  512. List.iter (fun lst -> Hashtbl.add res lst ("_" ^ lst)) ["abstract"; "assert"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class";
  513. "const"; "continue"; "default"; "do"; "double"; "else"; "enum"; "extends"; "final";
  514. "false"; "finally"; "float"; "for"; "goto"; "if"; "implements"; "import"; "instanceof"; "int";
  515. "interface"; "long"; "native"; "new"; "null"; "package"; "private"; "protected"; "public"; "return"; "short";
  516. "static"; "strictfp"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; "transient"; "true"; "try";
  517. "void"; "volatile"; "while"; ];
  518. res
  519. let dynamic_anon = TAnon( { a_fields = PMap.empty; a_status = ref Closed } )
  520. let rec get_class_modifiers meta cl_type cl_access cl_modifiers =
  521. match meta with
  522. | [] -> cl_type,cl_access,cl_modifiers
  523. (*| (":struct",[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers*)
  524. | (":protected",[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers
  525. | (":internal",[],_) :: meta -> get_class_modifiers meta cl_type "" cl_modifiers
  526. (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers)
  527. | (":static",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("static" :: cl_modifiers) TODO: support those types *)
  528. | (":final",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("final" :: cl_modifiers)
  529. | _ :: meta -> get_class_modifiers meta cl_type cl_access cl_modifiers
  530. let rec get_fun_modifiers meta access modifiers =
  531. match meta with
  532. | [] -> access,modifiers
  533. | (":protected",[],_) :: meta -> get_fun_modifiers meta "protected" modifiers
  534. | (":internal",[],_) :: meta -> get_fun_modifiers meta "" modifiers
  535. (*| (":readonly",[],_) :: meta -> get_fun_modifiers meta access ("readonly" :: modifiers)*)
  536. (*| (":unsafe",[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)*)
  537. | (":volatile",[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers)
  538. | _ :: meta -> get_fun_modifiers meta access modifiers
  539. (* this was the way I found to pass the generator context to be accessible across all functions here *)
  540. (* so 'configure' is almost 'top-level' and will have all functions needed to make this work *)
  541. let configure gen =
  542. let basic = gen.gcon.basic in
  543. let fn_cl = get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Function")) in
  544. let runtime_cl = get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Runtime")) in
  545. (*let string_ref = get_cl ( get_type gen (["haxe";"lang"], "StringRefl")) in*)
  546. let ti64 = match ( get_type gen ([], "Int64") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  547. let has_tdynamic params =
  548. List.exists (fun e -> match gen.greal_type e with | TDynamic _ -> true | _ -> false) params
  549. in
  550. (*
  551. The type parameters always need to be changed to their boxed counterparts
  552. *)
  553. let change_param_type md params =
  554. match md with
  555. | TClassDecl( { cl_path = (["java"], "NativeArray") } ) -> params
  556. | _ ->
  557. match params with
  558. | [] -> []
  559. | _ ->
  560. if has_tdynamic params then List.map (fun _ -> t_dynamic) params else
  561. List.map (fun t ->
  562. let f_t = gen.gfollow#run_f t in
  563. match gen.gfollow#run_f t with
  564. | TEnum ({ e_path = ([], "Bool") }, [])
  565. | TInst ({ cl_path = ([],"Float") },[])
  566. | TInst ({ cl_path = ["haxe"],"Int32" },[])
  567. | TInst ({ cl_path = ([],"Int") },[])
  568. | TType ({ t_path = [],"Int64" },[])
  569. | TType ({ t_path = ["haxe"],"Int64" },[])
  570. | TType ({ t_path = ["java"],"Int8" },[])
  571. | TType ({ t_path = ["java"],"Int16" },[])
  572. | TType ({ t_path = ["java"],"Char16" },[])
  573. | TType ({ t_path = [],"Single" },[]) -> basic.tnull f_t
  574. (*| TType ({ t_path = [], "Null"*)
  575. | _ -> t
  576. ) params
  577. in
  578. let rec change_ns ns = match ns with
  579. | [] -> ["haxe"; "root"]
  580. | _ -> ns
  581. in
  582. let change_clname n = n in
  583. let change_id name = try Hashtbl.find reserved name with | Not_found -> name in
  584. let change_field = change_id in
  585. let write_id w name = write w (change_id name) in
  586. let write_field w name = write w (change_field name) in
  587. gen.gfollow#add ~name:"follow_basic" (fun t -> match t with
  588. | TEnum ({ e_path = ([], "Bool") }, [])
  589. | TEnum ({ e_path = ([], "Void") }, [])
  590. | TInst ({ cl_path = ([],"Float") },[])
  591. | TInst ({ cl_path = ([],"Int") },[])
  592. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  593. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  594. | TType ({ t_path = [],"Int64" },[])
  595. | TType ({ t_path = ["java"],"Int8" },[])
  596. | TType ({ t_path = ["java"],"Int16" },[])
  597. | TType ({ t_path = ["java"],"Char16" },[])
  598. | TType ({ t_path = [],"Single" },[])
  599. | TType ({ t_path = [],"Null" },[_]) -> Some t
  600. | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic
  601. | _ -> None);
  602. let change_path path = (change_ns (fst path), change_clname (snd path)) in
  603. let path_s path = match path with
  604. | (ns,clname) -> path_s (change_ns ns, change_clname clname)
  605. in
  606. let cl_cl = get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Class")) in
  607. let rec real_type t =
  608. let t = gen.gfollow#run_f t in
  609. match t with
  610. | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint
  611. | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64
  612. | TInst( { cl_path = ([], "Class") }, _ )
  613. | TInst( { cl_path = ([], "Enum") }, _ ) -> TInst(cl_cl,[])
  614. | TEnum _
  615. | TInst _ -> t
  616. | TType({ t_path = ([], "Null") }, [t]) when is_java_basic_type t -> t_dynamic
  617. | TType({ t_path = ([], "Null") }, [t]) ->
  618. (match follow t with
  619. | TInst( { cl_kind = KTypeParameter }, []) -> t_dynamic
  620. | _ -> real_type t
  621. )
  622. | TType _ -> t
  623. | TAnon (anon) when (match !(anon.a_status) with | Statics _ | EnumStatics _ -> true | _ -> false) -> t
  624. | TAnon _ -> dynamic_anon
  625. | TFun _ -> TInst(fn_cl,[])
  626. | _ -> t_dynamic
  627. in
  628. let is_dynamic t = match real_type t with
  629. | TMono _ | TDynamic _ -> true
  630. | TAnon anon ->
  631. (match !(anon.a_status) with
  632. | EnumStatics _ | Statics _ -> false
  633. | _ -> true
  634. )
  635. | _ -> false
  636. in
  637. let rec t_s t =
  638. match real_type t with
  639. (* basic types *)
  640. | TEnum ({ e_path = ([], "Bool") }, []) -> "boolean"
  641. | TEnum ({ e_path = ([], "Void") }, []) -> "java.lang.Object"
  642. | TInst ({ cl_path = ([],"Float") },[]) -> "double"
  643. | TInst ({ cl_path = ([],"Int") },[]) -> "int"
  644. | TType ({ t_path = [],"Int64" },[]) -> "long"
  645. | TType ({ t_path = ["java"],"Int8" },[]) -> "byte"
  646. | TType ({ t_path = ["java"],"Int16" },[]) -> "short"
  647. | TType ({ t_path = ["java"],"Char16" },[]) -> "char"
  648. | TType ({ t_path = [],"Single" },[]) -> "float"
  649. | TInst ({ cl_path = ["haxe"],"Int32" },[]) -> "int"
  650. | TInst ({ cl_path = ["haxe"],"Int64" },[]) -> "long"
  651. | TInst ({ cl_path = ([], "Dynamic") }, _) -> "java.lang.Object"
  652. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  653. let rec check_t_s t =
  654. match real_type t with
  655. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  656. (check_t_s param) ^ "[]"
  657. | _ -> t_s (run_follow gen t)
  658. in
  659. (check_t_s param) ^ "[]"
  660. (* end of basic types *)
  661. | TInst ({ cl_kind = KTypeParameter; cl_path=p }, []) -> snd p
  662. | TMono r -> (match !r with | None -> "java.lang.Object" | Some t -> t_s (run_follow gen t))
  663. | TInst ({ cl_path = [], "String" }, []) -> "java.lang.String"
  664. | TInst ({ cl_path = [], "Class" }, _) | TInst ({ cl_path = [], "Enum" }, _) -> "haxe.lang.Class"
  665. | TEnum (({e_path = p;} as e), params) -> (path_param_s (TEnumDecl e) p params)
  666. | TInst (({cl_path = p;} as cl), params) -> (path_param_s (TClassDecl cl) p params)
  667. | TType (({t_path = p;} as t), params) -> (path_param_s (TTypeDecl t) p params)
  668. | TAnon (anon) ->
  669. (match !(anon.a_status) with
  670. | Statics _ | EnumStatics _ -> "haxe.lang.Class"
  671. | _ -> "java.lang.Object")
  672. | TDynamic _ -> "java.lang.Object"
  673. (* No Lazy type nor Function type made. That's because function types will be at this point be converted into other types *)
  674. | _ -> if !strict_mode then begin trace ("[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]"); assert false end else "[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]"
  675. and param_t_s t =
  676. match run_follow gen t with
  677. | TEnum ({ e_path = ([], "Bool") }, []) -> "java.lang.Boolean"
  678. | TInst ({ cl_path = ([],"Float") },[]) -> "java.lang.Double"
  679. | TInst ({ cl_path = ([],"Int") },[]) -> "java.lang.Integer"
  680. | TType ({ t_path = [],"Int64" },[]) -> "java.lang.Long"
  681. | TInst ({ cl_path = ["haxe"],"Int64" },[]) -> "java.lang.Long"
  682. | TInst ({ cl_path = ["haxe"],"Int32" },[]) -> "java.lang.Integer"
  683. | TType ({ t_path = ["java"],"Int8" },[]) -> "java.lang.Byte"
  684. | TType ({ t_path = ["java"],"Int16" },[]) -> "java.lang.Short"
  685. | TType ({ t_path = ["java"],"Char16" },[]) -> "java.lang.Character"
  686. | TType ({ t_path = [],"Single" },[]) -> "java.lang.Float"
  687. | TDynamic _ -> "?"
  688. | TInst (cl, params) -> t_s (TInst(cl, change_param_type (TClassDecl cl) params))
  689. | TType (cl, params) -> t_s (TType(cl, change_param_type (TTypeDecl cl) params))
  690. | TEnum (e, params) -> t_s (TEnum(e, change_param_type (TEnumDecl e) params))
  691. | _ -> t_s t
  692. and path_param_s md path params =
  693. match params with
  694. | [] -> path_s path
  695. | _ when has_tdynamic params -> path_s path
  696. | _ -> sprintf "%s<%s>" (path_s path) (String.concat ", " (List.map (fun t -> param_t_s t) (change_param_type md params)))
  697. in
  698. let rett_s t =
  699. match t with
  700. | TEnum ({e_path = ([], "Void")}, []) -> "void"
  701. | _ -> t_s t
  702. in
  703. let escape s =
  704. let b = Buffer.create 0 in
  705. for i = 0 to String.length s - 1 do
  706. match String.unsafe_get s i with
  707. | '\\' -> Buffer.add_string b "\\\\"
  708. | '\'' -> Buffer.add_string b "\\\'"
  709. | '\"' -> Buffer.add_string b "\\\""
  710. | '\r' -> Buffer.add_string b "\\r"
  711. | '\n' -> Buffer.add_string b "\\n"
  712. | '\t' -> Buffer.add_string b "\\t"
  713. | c when (Char.code c) < 32 -> Buffer.add_string b (Printf.sprintf "\\u00%.2X" (Char.code c))
  714. | c -> Buffer.add_char b c
  715. done;
  716. Buffer.contents b
  717. in
  718. let has_semicolon e =
  719. match e.eexpr with
  720. | TLocal { v_name = "__fallback__" }
  721. | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt _) } ] ) -> false
  722. | TBlock _ | TFor _ | TSwitch _ | TMatch _ | TTry _ | TIf _ -> false
  723. | TWhile (_,_,flag) when flag = Ast.NormalWhile -> false
  724. | _ -> true
  725. in
  726. let in_value = ref false in
  727. let rec md_s md =
  728. let md = follow_module (gen.gfollow#run_f) md in
  729. match md with
  730. | TClassDecl (cl) ->
  731. t_s (TInst(cl,[]))
  732. | TEnumDecl (e) ->
  733. t_s (TEnum(e,[]))
  734. | TTypeDecl t ->
  735. t_s (TType(t, []))
  736. in
  737. let expr_s w e =
  738. in_value := false;
  739. let rec expr_s w e =
  740. let was_in_value = !in_value in
  741. in_value := true;
  742. match e.eexpr with
  743. | TConst c ->
  744. (match c with
  745. | TInt i32 ->
  746. print w "%ld" i32;
  747. (match real_type e.etype with
  748. | TType( { t_path = ([], "Int64") }, [] ) -> write w "L";
  749. | _ -> ()
  750. )
  751. | TFloat s ->
  752. write w s;
  753. (match real_type e.etype with
  754. | TType( { t_path = ([], "Single") }, [] ) -> write w "f"
  755. | _ -> ()
  756. )
  757. | TString s -> print w "\"%s\"" (escape s)
  758. | TBool b -> write w (if b then "true" else "false")
  759. | TNull ->
  760. (match real_type e.etype with
  761. | TType( { t_path = ([], "Int64") }, [] )
  762. | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> write w "0L"
  763. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  764. | TInst({ cl_path = ([], "Int") },[]) -> expr_s w ({ e with eexpr = TConst(TInt Int32.zero) })
  765. | TInst({ cl_path = ([], "Float") },[]) -> expr_s w ({ e with eexpr = TConst(TFloat "0.0") })
  766. | TEnum({ e_path = ([], "Bool") }, []) -> write w "false"
  767. | _ -> write w "null")
  768. | TThis -> write w "this"
  769. | TSuper -> write w "super")
  770. | TLocal { v_name = "__fallback__" } -> ()
  771. | TLocal { v_name = "__undefined__" } ->
  772. write w (t_s (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_types)));
  773. write w ".undefined";
  774. | TLocal var ->
  775. write_id w var.v_name
  776. | TEnumField (e, s) ->
  777. print w "%s." (path_s e.e_path); write_field w s
  778. | TArray (e1, e2) ->
  779. expr_s w e1; write w "["; expr_s w e2; write w "]"
  780. | TBinop (op, e1, e2) ->
  781. expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2
  782. | TField (e, s) | TClosure (e, s) ->
  783. expr_s w e; write w "."; write_field w s
  784. | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int32") }) ->
  785. write w (path_s (["haxe"], "Int32"))
  786. | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int64") }) ->
  787. write w (path_s (["haxe"], "Int64"))
  788. | TTypeExpr mt ->
  789. (*(match mt with
  790. | TClassDecl { cl_path = (["haxe"], "Int32") } -> write w (path_s (["haxe"], "Int32"))
  791. | TClassDecl cl -> write w (t_s (TInst(cl, List.map (fun _ -> t_empty) cl.cl_types)))
  792. | TEnumDecl en -> write w (t_s (TEnum(en, List.map (fun _ -> t_empty) en.e_types)))
  793. | TTypeDecl td -> write w (t_s (gen.gfollow#run_f (TType(td, List.map (fun _ -> t_empty) td.t_types)))) )*)
  794. write w (md_s mt)
  795. | TParenthesis e ->
  796. write w "("; expr_s w e; write w ")"
  797. | TArrayDecl el when t_has_type_param_shallow false e.etype ->
  798. print w "( (%s) (new java.lang.Object[] " (t_s e.etype);
  799. write w "{";
  800. ignore (List.fold_left (fun acc e ->
  801. (if acc <> 0 then write w ", ");
  802. expr_s w e;
  803. acc + 1
  804. ) 0 el);
  805. write w "}) )"
  806. | TArrayDecl el ->
  807. (*
  808. it seems that Java doesn't like when you create a new array with the type parameter defined
  809. so we'll just ignore all type parameters, and hope for the best!
  810. *)
  811. let rec transform_t t = match gen.gfollow#run_f t with
  812. | TInst( ({ cl_path = (["java"], "NativeArray") } as narr), [t]) ->
  813. TInst(narr, [transform_t t])
  814. | TInst(cl, params) -> TInst(cl, List.map (fun _ -> t_dynamic) params)
  815. | TEnum(e, params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
  816. | TType(t, params) -> TType(t, List.map (fun _ -> t_dynamic) params)
  817. | _ -> t
  818. in
  819. print w "new %s" (param_t_s (transform_t e.etype));
  820. let is_double = match follow e.etype with
  821. | TInst(_,[ t ]) -> ( match follow t with | TInst({ cl_path=([],"Float") },[]) -> Some t | _ -> None )
  822. | _ -> None
  823. in
  824. write w "{";
  825. ignore (List.fold_left (fun acc e ->
  826. (if acc <> 0 then write w ", ");
  827. (* this is a hack so we are able to convert ints to boxed Double / Float when needed *)
  828. let e = if is_some is_double then mk_cast (get is_double) e else e in
  829. expr_s w e;
  830. acc + 1
  831. ) 0 el);
  832. write w "}"
  833. | TCall( ( { eexpr = TField({ eexpr = TTypeExpr (TClassDecl { cl_path = ([], "String") }) }, "fromCharCode") } ), [cc] ) ->
  834. write w "Character.toString((char) ";
  835. expr_s w cc;
  836. write w ")"
  837. | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
  838. write w "( ";
  839. expr_s w expr;
  840. write w " instanceof ";
  841. write w (md_s md);
  842. write w " )"
  843. | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) ->
  844. write w s
  845. | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
  846. print w "break label%ld" v
  847. | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
  848. print w "label%ld:" v
  849. | TCall ({ eexpr = TLocal( { v_name = "__typeof__" } ) }, [ { eexpr = TTypeExpr md } ] ) ->
  850. print w "%s.class" (md_s md)
  851. | TCall (e, el) ->
  852. let rec extract_tparams params el =
  853. match el with
  854. | ({ eexpr = TLocal({ v_name = "$type_param" }) } as tp) :: tl ->
  855. extract_tparams (tp.etype :: params) tl
  856. | _ -> (params, el)
  857. in
  858. let params, el = extract_tparams [] el in
  859. expr_s w e;
  860. (*(match params with
  861. | [] -> ()
  862. | params ->
  863. let md = match e.eexpr with
  864. | TField(ef, _) -> t_to_md (run_follow gen ef.etype)
  865. | _ -> assert false
  866. in
  867. write w "<";
  868. ignore (List.fold_left (fun acc t ->
  869. (if acc <> 0 then write w ", ");
  870. write w (param_t_s (change_param_type md t));
  871. acc + 1
  872. ) 0 params);
  873. write w ">"
  874. );*)
  875. write w "(";
  876. ignore (List.fold_left (fun acc e ->
  877. (if acc <> 0 then write w ", ");
  878. expr_s w e;
  879. acc + 1
  880. ) 0 el);
  881. write w ")"
  882. | TNew (({ cl_path = (["java"], "NativeArray") } as cl), params, [ size ]) ->
  883. let rec check_t_s t times =
  884. match real_type t with
  885. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  886. (check_t_s param (times+1))
  887. | _ ->
  888. print w "new %s[" (t_s (run_follow gen t));
  889. expr_s w size;
  890. print w "]";
  891. let rec loop i =
  892. if i <= 0 then () else (write w "[]"; loop (i-1))
  893. in
  894. loop (times - 1)
  895. in
  896. check_t_s (TInst(cl, params)) 0
  897. | TNew (cl, params, el) ->
  898. write w "new ";
  899. write w (path_param_s (TClassDecl cl) cl.cl_path params);
  900. write w "(";
  901. ignore (List.fold_left (fun acc e ->
  902. (if acc <> 0 then write w ", ");
  903. expr_s w e;
  904. acc + 1
  905. ) 0 el);
  906. write w ")"
  907. | TUnop ((Ast.Increment as op), flag, e)
  908. | TUnop ((Ast.Decrement as op), flag, e) ->
  909. (match flag with
  910. | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " " ); expr_s w e
  911. | Ast.Postfix -> expr_s w e; write w (Ast.s_unop op))
  912. | TUnop (op, flag, e) ->
  913. (match flag with
  914. | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " (" ); expr_s w e; write w ") "
  915. | Ast.Postfix -> write w "("; expr_s w e; write w (") " ^ Ast.s_unop op))
  916. | TVars (v_eop_l) ->
  917. ignore (List.fold_left (fun acc (var, eopt) ->
  918. (if acc <> 0 then write w "; ");
  919. print w "%s " (t_s var.v_type);
  920. write_id w var.v_name;
  921. (match eopt with
  922. | None -> ()
  923. | Some e ->
  924. write w " = ";
  925. expr_s w e
  926. );
  927. acc + 1
  928. ) 0 v_eop_l);
  929. | TBlock [e] when was_in_value ->
  930. expr_s w e
  931. | TBlock el ->
  932. begin_block w;
  933. (*let last_line = ref (-1) in
  934. let line_directive p =
  935. let cur_line = Lexer.get_error_line p in
  936. let is_relative_path = (String.sub p.pfile 0 1) = "." in
  937. let file = if is_relative_path then "../" ^ p.pfile else p.pfile in
  938. if cur_line <> ((!last_line)+1) then begin print w "//#line %d \"%s\"" cur_line (Ast.s_escape file); newline w end;
  939. last_line := cur_line in*)
  940. List.iter (fun e ->
  941. (*line_directive e.epos;*)
  942. in_value := false;
  943. expr_s w e;
  944. (if has_semicolon e then write w ";");
  945. newline w
  946. ) el;
  947. end_block w
  948. | TIf (econd, e1, Some(eelse)) when was_in_value ->
  949. write w "( ";
  950. expr_s w (mk_paren econd);
  951. write w " ? ";
  952. expr_s w (mk_paren e1);
  953. write w " : ";
  954. expr_s w (mk_paren eelse);
  955. write w " )";
  956. | TIf (econd, e1, eelse) ->
  957. write w "if ";
  958. expr_s w (mk_paren econd);
  959. write w " ";
  960. in_value := false;
  961. expr_s w (mk_block e1);
  962. (match eelse with
  963. | None -> ()
  964. | Some e ->
  965. write w " else ";
  966. in_value := false;
  967. expr_s w (mk_block e)
  968. )
  969. | TWhile (econd, eblock, flag) ->
  970. (match flag with
  971. | Ast.NormalWhile ->
  972. write w "while ";
  973. expr_s w (mk_paren econd);
  974. write w "";
  975. in_value := false;
  976. expr_s w (mk_block eblock)
  977. | Ast.DoWhile ->
  978. write w "do ";
  979. in_value := false;
  980. expr_s w (mk_block eblock);
  981. write w "while ";
  982. in_value := true;
  983. expr_s w (mk_paren econd);
  984. )
  985. | TSwitch (econd, ele_l, default) ->
  986. write w "switch ";
  987. expr_s w (mk_paren econd);
  988. begin_block w;
  989. List.iter (fun (el, e) ->
  990. List.iter (fun e ->
  991. write w "case ";
  992. in_value := true;
  993. expr_s w e;
  994. write w ":";
  995. ) el;
  996. newline w;
  997. in_value := false;
  998. expr_s w (mk_block e);
  999. newline w;
  1000. (if not (JavaSpecificSynf.is_final_return_expr true e) then write w "break;");
  1001. newline w
  1002. ) ele_l;
  1003. if is_some default then begin
  1004. write w "default:";
  1005. newline w;
  1006. in_value := false;
  1007. expr_s w (get default);
  1008. newline w;
  1009. (if not (JavaSpecificSynf.is_final_return_expr true (get default)) then write w "break;");
  1010. end;
  1011. end_block w
  1012. | TTry (tryexpr, ve_l) ->
  1013. write w "try ";
  1014. in_value := false;
  1015. expr_s w (mk_block tryexpr);
  1016. List.iter (fun (var, e) ->
  1017. print w "catch (%s %s)" (t_s var.v_type) (var.v_name);
  1018. in_value := false;
  1019. expr_s w (mk_block e);
  1020. newline w
  1021. ) ve_l
  1022. | TReturn eopt ->
  1023. write w "return ";
  1024. if is_some eopt then expr_s w (get eopt)
  1025. | TBreak -> write w "break"
  1026. | TContinue -> write w "continue"
  1027. | TThrow e ->
  1028. write w "throw ";
  1029. expr_s w e
  1030. | TCast (e1,md_t) ->
  1031. ((*match gen.gfollow#run_f e.etype with
  1032. | TType({ t_path = ([], "UInt") }, []) ->
  1033. write w "( unchecked ((uint) ";
  1034. expr_s w e1;
  1035. write w ") )"
  1036. | _ ->*)
  1037. (* FIXME I'm ignoring module type *)
  1038. print w "((%s) (" (t_s e.etype);
  1039. expr_s w e1;
  1040. write w ") )"
  1041. )
  1042. | TFor (_,_,content) ->
  1043. write w "[ for not supported ";
  1044. expr_s w content;
  1045. write w " ]";
  1046. if !strict_mode then assert false
  1047. | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
  1048. | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
  1049. | TMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false
  1050. in
  1051. expr_s w e
  1052. in
  1053. let get_string_params cl_types =
  1054. match cl_types with
  1055. | [] ->
  1056. ("","")
  1057. | _ ->
  1058. let params = sprintf "<%s>" (String.concat ", " (List.map (fun (_, tcl) -> match follow tcl with | TInst(cl, _) -> snd cl.cl_path | _ -> assert false) cl_types)) in
  1059. let params_extends = List.fold_left (fun acc (name, t) ->
  1060. match run_follow gen t with
  1061. | TInst (cl, p) ->
  1062. (match cl.cl_implements with
  1063. | [] -> acc
  1064. | _ -> acc) (* TODO
  1065. | _ -> (sprintf " where %s : %s" name (String.concat ", " (List.map (fun (cl,p) -> path_param_s (TClassDecl cl) cl.cl_path p) cl.cl_implements))) :: acc ) *)
  1066. | _ -> trace (t_s t); assert false (* FIXME it seems that a cl_types will never be anything other than cl.cl_types. I'll take the risk and fail if not, just to see if that confirms *)
  1067. ) [] cl_types in
  1068. (params, String.concat " " params_extends)
  1069. in
  1070. let gen_class_field w is_static cl is_final cf =
  1071. let is_interface = cl.cl_interface in
  1072. let name, is_new, is_explicit_iface = match cf.cf_name with
  1073. | "new" -> snd cl.cl_path, true, false
  1074. | name when String.contains name '.' ->
  1075. let fn_name, path = parse_explicit_iface name in
  1076. (path_s path) ^ "." ^ fn_name, false, true
  1077. | name -> name, false, false
  1078. in
  1079. (match cf.cf_kind with
  1080. | Var _
  1081. | Method (MethDynamic) ->
  1082. if not is_interface then begin
  1083. let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in
  1084. print w "%s %s%s %s %s;" access (if is_static then "static " else "") (String.concat " " modifiers) (t_s (run_follow gen cf.cf_type)) (change_field name)
  1085. end (* TODO see how (get,set) variable handle when they are interfaces *)
  1086. | Method mkind ->
  1087. let is_virtual = is_new || (not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false) in
  1088. let is_override = match cf.cf_name with
  1089. | "toString" | "equals" when not is_static -> true
  1090. | _ -> List.mem cf.cf_name cl.cl_overrides
  1091. in
  1092. let visibility = if is_interface then "" else "public" in
  1093. let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in
  1094. let visibility, is_virtual = if is_explicit_iface then "",false else visibility, is_virtual in
  1095. let v_n = if is_static then "static " else if is_override && not is_interface then "" else if not is_virtual then "final " else "" in
  1096. let cf_type = if is_override then match field_access gen (TInst(cl, List.map snd cl.cl_types)) cf.cf_name with | FClassField(_,_,_,_,actual_t) -> actual_t | _ -> assert false else cf.cf_type in
  1097. let params = List.map snd cl.cl_types in
  1098. let ret_type, args = match cf_type, cf.cf_type with | TFun (strbtl, t), TFun(rargs, _) -> (apply_params cl.cl_types params (real_type t), List.map2 (fun(_,_,t) (n,o,_) -> (n,o,apply_params cl.cl_types params (real_type t))) strbtl rargs) | _ -> assert false in
  1099. (if is_override && not is_interface then write w "@Override ");
  1100. (* public static void funcName *)
  1101. let params, _ = get_string_params cf.cf_params in
  1102. print w "%s %s%s %s %s %s" (visibility) v_n (String.concat " " modifiers) params (if is_new then "" else rett_s (run_follow gen ret_type)) (change_field name);
  1103. (* <T>(string arg1, object arg2) with T : object *)
  1104. print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (t_s (run_follow gen t)) (change_id name)) args));
  1105. if is_interface then
  1106. write w ";"
  1107. else begin
  1108. let rec loop meta =
  1109. match meta with
  1110. | [] ->
  1111. let expr = match cf.cf_expr with
  1112. | None -> mk (TBlock([])) t_dynamic Ast.null_pos
  1113. | Some s ->
  1114. match s.eexpr with
  1115. | TFunction tf ->
  1116. mk_block (tf.tf_expr)
  1117. | _ -> assert false (* FIXME *)
  1118. in
  1119. (if is_new then begin
  1120. let rec get_super_call el =
  1121. match el with
  1122. | ( { eexpr = TCall( { eexpr = TConst(TSuper) }, _) } as call) :: rest ->
  1123. Some call, rest
  1124. | ( { eexpr = TBlock(bl) } as block ) :: rest ->
  1125. let ret, mapped = get_super_call bl in
  1126. ret, ( { block with eexpr = TBlock(mapped) } :: rest )
  1127. | _ ->
  1128. None, el
  1129. in
  1130. expr_s w expr
  1131. end else begin
  1132. expr_s w expr;
  1133. end)
  1134. | (":throws", [Ast.EConst (Ast.String t), _], _) :: tl ->
  1135. print w " throws %s" t;
  1136. loop tl
  1137. | (":functionBody", [Ast.EConst (Ast.String contents),_],_) :: tl ->
  1138. begin_block w;
  1139. write w contents;
  1140. end_block w
  1141. | _ :: tl -> loop tl
  1142. in
  1143. loop cf.cf_meta
  1144. end);
  1145. newline w;
  1146. newline w
  1147. in
  1148. let gen_class w cl =
  1149. let should_close = match change_ns (fst cl.cl_path) with
  1150. | [] -> false
  1151. | ns ->
  1152. print w "package %s;" (String.concat "." (change_ns ns));
  1153. newline w;
  1154. false
  1155. in
  1156. write w "import haxe.root.*;";
  1157. newline w;
  1158. write w "@SuppressWarnings(value={\"rawtypes\", \"unchecked\"})";
  1159. newline w;
  1160. let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
  1161. let is_final = has_meta ":final" cl.cl_meta in
  1162. print w "%s %s%s %s" access (String.concat " " modifiers) clt (change_clname (snd cl.cl_path));
  1163. (* type parameters *)
  1164. let params, _ = get_string_params cl.cl_types in
  1165. let cl_p_to_string (cl,p) = path_param_s (TClassDecl cl) cl.cl_path p in
  1166. print w "%s" params;
  1167. (if is_some cl.cl_super then print w " extends %s" (cl_p_to_string (get cl.cl_super)));
  1168. (match cl.cl_implements with
  1169. | [] -> ()
  1170. | _ -> print w " %s %s" (if cl.cl_interface then "extends" else "implements") (String.concat ", " (List.map cl_p_to_string cl.cl_implements))
  1171. );
  1172. (* class head ok: *)
  1173. (* public class Test<A> : X, Y, Z where A : Y *)
  1174. begin_block w;
  1175. (* our constructor is expected to be a normal "new" function *
  1176. if !strict_mode && is_some cl.cl_constructor then assert false;*)
  1177. let rec loop meta =
  1178. match meta with
  1179. | [] -> ()
  1180. | (":classContents", [Ast.EConst (Ast.String contents),_],_) :: tl ->
  1181. write w contents
  1182. | _ :: tl -> loop tl
  1183. in
  1184. loop cl.cl_meta;
  1185. (match gen.gcon.main_class with
  1186. | Some path when path = cl.cl_path ->
  1187. write w "public static void main(String[] args)";
  1188. begin_block w;
  1189. write w "main();";
  1190. end_block w
  1191. | _ -> ()
  1192. );
  1193. (match cl.cl_init with
  1194. | None -> ()
  1195. | Some init ->
  1196. write w "static ";
  1197. expr_s w (mk_block init));
  1198. (if is_some cl.cl_constructor then gen_class_field w false cl is_final (get cl.cl_constructor));
  1199. (if not cl.cl_interface then
  1200. List.iter (gen_class_field w true cl is_final) cl.cl_ordered_statics);
  1201. List.iter (gen_class_field w false cl is_final) cl.cl_ordered_fields;
  1202. end_block w;
  1203. if should_close then end_block w
  1204. in
  1205. let gen_enum w e =
  1206. let should_close = match change_ns (fst e.e_path) with
  1207. | [] -> false
  1208. | ns ->
  1209. print w "package %s;" (String.concat "." (change_ns ns));
  1210. newline w;
  1211. false
  1212. in
  1213. print w "public enum %s" (change_clname (snd e.e_path));
  1214. begin_block w;
  1215. write w (String.concat ", " e.e_names);
  1216. end_block w;
  1217. if should_close then end_block w
  1218. in
  1219. let module_type_gen w md_tp =
  1220. match md_tp with
  1221. | TClassDecl cl ->
  1222. if not cl.cl_extern then begin
  1223. gen_class w cl;
  1224. newline w;
  1225. newline w
  1226. end;
  1227. (not cl.cl_extern)
  1228. | TEnumDecl e ->
  1229. if not e.e_extern then begin
  1230. gen_enum w e;
  1231. newline w;
  1232. newline w
  1233. end;
  1234. (not e.e_extern)
  1235. | TTypeDecl e ->
  1236. false
  1237. in
  1238. let module_gen w md =
  1239. module_type_gen w md
  1240. in
  1241. (* generate source code *)
  1242. init_ctx gen;
  1243. Hashtbl.add gen.gspecial_vars "__label__" true;
  1244. Hashtbl.add gen.gspecial_vars "__goto__" true;
  1245. Hashtbl.add gen.gspecial_vars "__is__" true;
  1246. Hashtbl.add gen.gspecial_vars "__typeof__" true;
  1247. Hashtbl.add gen.gspecial_vars "__java__" true;
  1248. gen.greal_type <- real_type;
  1249. gen.greal_type_param <- change_param_type;
  1250. SetHXGen.run_filter gen SetHXGen.default_hxgen_func;
  1251. let closure_t = ClosuresToClass.DoubleAndDynamicClosureImpl.get_ctx gen 6 in
  1252. (*let closure_t = ClosuresToClass.create gen 10 float_cl
  1253. (fun l -> l)
  1254. (fun l -> l)
  1255. (fun args -> args)
  1256. (fun args -> [])
  1257. in
  1258. ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (fun e _ _ -> e));
  1259. StubClosureImpl.configure gen (StubClosureImpl.default_implementation gen float_cl 10 (fun e _ _ -> e));*)
  1260. IteratorsInterface.configure gen (fun e -> e);
  1261. ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Function")) ));
  1262. EnumToClass.configure gen (None) false true (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Enum")) );
  1263. InterfaceVarsDeleteModf.configure gen;
  1264. let dynamic_object = (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"DynamicObject")) ) in
  1265. let object_iface = get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"IHxObject")) in
  1266. (*fixme: THIS IS A HACK. take this off *)
  1267. let empty_e = match (get_type gen (["haxe";"lang"], "EmptyObject")) with | TEnumDecl e -> e | _ -> assert false in
  1268. (*OverloadingCtor.set_new_create_empty gen ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;});*)
  1269. OverloadingConstructor.configure gen (TEnum(empty_e, [])) ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;}) false;
  1270. let rcf_static_find = mk_static_field_access_infer (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"], "FieldLookup"))) "findHash" Ast.null_pos [] in
  1271. (*let rcf_static_lookup = mk_static_field_access_infer (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"], "FieldLookup"))) "lookupHash" Ast.null_pos [] in*)
  1272. let can_be_float t = match follow t with
  1273. | TInst({ cl_path = (["haxe"], "Int32")}, [] )
  1274. | TInst({ cl_path = ([], "Int") }, [])
  1275. | TInst({ cl_path = ([], "Float") }, []) -> true
  1276. | _ -> false
  1277. in
  1278. let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe =
  1279. let is_float = can_be_float (if is_none may_set then main_expr.etype else (get may_set).etype) in
  1280. let fn_name = if is_some may_set then "setField" else "getField" in
  1281. let fn_name = if is_float then fn_name ^ "_f" else fn_name in
  1282. let pos = field_expr.epos in
  1283. let is_unsafe = { eexpr = TConst(TBool is_unsafe); etype = basic.tbool; epos = pos } in
  1284. let should_cast = match main_expr.etype with | TInst({ cl_path = ([], "Float") }, []) -> false | _ -> true in
  1285. let infer = mk_static_field_access_infer runtime_cl fn_name field_expr.epos [] in
  1286. let first_args =
  1287. [ field_expr; { eexpr = TConst(TString field); etype = basic.tstring; epos = pos } ]
  1288. @ if is_some may_hash then [ { eexpr = TConst(TInt (get may_hash)); etype = basic.tint; epos = pos } ] else []
  1289. in
  1290. let args = first_args @ match is_float, may_set with
  1291. | true, Some(set) ->
  1292. [ if should_cast then mk_cast basic.tfloat set else set ]
  1293. | false, Some(set) ->
  1294. [ set ]
  1295. | _ ->
  1296. [ is_unsafe ]
  1297. in
  1298. let call = { main_expr with eexpr = TCall(infer,args) } in
  1299. let call = if is_float && should_cast then mk_cast main_expr.etype call else call in
  1300. call
  1301. in
  1302. let rcf_on_call_field ecall field_expr field may_hash args =
  1303. let infer = mk_static_field_access_infer runtime_cl "callField" field_expr.epos [] in
  1304. let hash_arg = match may_hash with
  1305. | None -> []
  1306. | Some h -> [ { eexpr = TConst(TInt h); etype = basic.tint; epos = field_expr.epos } ]
  1307. in
  1308. let arr_call = if args <> [] then
  1309. { eexpr = TArrayDecl args; etype = basic.tarray t_dynamic; epos = ecall.epos }
  1310. else
  1311. null (basic.tarray t_dynamic) ecall.epos
  1312. in
  1313. let call_args =
  1314. [field_expr; { field_expr with eexpr = TConst(TString field); etype = basic.tstring } ]
  1315. @ hash_arg
  1316. @ [ arr_call ]
  1317. in
  1318. mk_cast ecall.etype { ecall with eexpr = TCall(infer, call_args); etype = t_dynamic }
  1319. in
  1320. let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface false rcf_on_getset_field rcf_on_call_field (fun hash hash_array ->
  1321. { hash with eexpr = TCall(rcf_static_find, [hash; hash_array]); etype=basic.tint }
  1322. ) (fun hash -> hash ) in
  1323. ReflectionCFs.set_universal_base_class gen (get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"HxObject")) ) object_iface dynamic_object;
  1324. ReflectionCFs.implement_class_methods rcf_ctx ( get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Class")) );
  1325. ReflectionCFs.configure_dynamic_field_access rcf_ctx false;
  1326. let closure_func = ReflectionCFs.implement_closure_cl rcf_ctx ( get_cl (Hashtbl.find gen.gtypes (["haxe";"lang"],"Closure")) ) in
  1327. ReflectionCFs.implement_varargs_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"], "VarArgsBase")) );
  1328. ReflectionCFs.configure rcf_ctx;
  1329. let objdecl_fn = ReflectionCFs.implement_dynamic_object_ctor rcf_ctx dynamic_object in
  1330. ObjectDeclMap.configure gen (ObjectDeclMap.traverse gen objdecl_fn);
  1331. InitFunction.configure gen true;
  1332. TArrayTransform.configure gen (TArrayTransform.default_implementation gen (
  1333. fun e ->
  1334. match e.eexpr with
  1335. | TArray(e1, e2) ->
  1336. ( match follow e1.etype with
  1337. | TInst({ cl_path = (["java"], "NativeArray") }, _) -> false
  1338. | _ -> true )
  1339. | _ -> assert false
  1340. ) "__get" "__set" );
  1341. let field_is_dynamic t field =
  1342. match field_access gen (gen.greal_type t) field with
  1343. | FClassField (cl,p,_,_,t) ->
  1344. is_dynamic (apply_params cl.cl_types p t)
  1345. | FEnumField _ -> false
  1346. | _ -> true
  1347. in
  1348. let is_type_param e = match follow e with
  1349. | TInst( { cl_kind = KTypeParameter },[]) -> true
  1350. | _ -> false
  1351. in
  1352. let is_dynamic_expr e = is_dynamic e.etype || match e.eexpr with
  1353. | TField(tf, f) -> field_is_dynamic tf.etype f
  1354. | _ -> false
  1355. in
  1356. let may_nullable t = match gen.gfollow#run_f t with
  1357. | TType({ t_path = ([], "Null") }, [t]) ->
  1358. (match follow t with
  1359. | TInst({ cl_path = ([], "String") }, [])
  1360. | TInst({ cl_path = ([], "Float") }, [])
  1361. | TInst({ cl_path = (["haxe"], "Int32")}, [] )
  1362. | TInst({ cl_path = (["haxe"], "Int64")}, [] )
  1363. | TInst({ cl_path = ([], "Int") }, [])
  1364. | TEnum({ e_path = ([], "Bool") }, []) -> Some t
  1365. | _ -> None )
  1366. | _ -> None
  1367. in
  1368. let is_double t = match follow t with | TInst({ cl_path = ([], "Float") }, []) -> true | _ -> false in
  1369. let is_int t = match follow t with | TInst({ cl_path = ([], "Int") }, []) -> true | _ -> false in
  1370. DynamicOperators.configure gen
  1371. (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with
  1372. | TBinop (Ast.OpEq, e1, e2)
  1373. | TBinop (Ast.OpAdd, e1, e2)
  1374. | TBinop (Ast.OpNotEq, e1, e2) -> is_dynamic e1.etype or is_dynamic e2.etype or is_type_param e1.etype or is_type_param e2.etype
  1375. | TBinop (Ast.OpLt, e1, e2)
  1376. | TBinop (Ast.OpLte, e1, e2)
  1377. | TBinop (Ast.OpGte, e1, e2)
  1378. | TBinop (Ast.OpGt, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2 or is_string e1.etype or is_string e2.etype
  1379. | TBinop (_, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2
  1380. | TUnop (_, _, e1) -> is_dynamic_expr e1
  1381. | _ -> false)
  1382. (fun e1 e2 ->
  1383. let is_null e = match e.eexpr with | TConst(TNull) | TLocal({ v_name = "__undefined__" }) -> true | _ -> false in
  1384. if is_null e1 || is_null e2 then
  1385. { e1 with eexpr = TBinop(Ast.OpEq, e1, e2); etype = basic.tbool }
  1386. else begin
  1387. let is_ref = match follow e1.etype, follow e2.etype with
  1388. | TDynamic _, _
  1389. | _, TDynamic _
  1390. | TInst({ cl_path = ([], "Float") },[]), _
  1391. | TInst( { cl_path = (["haxe"], "Int32") }, [] ), _
  1392. | TInst( { cl_path = (["haxe"], "Int64") }, [] ), _
  1393. | TInst({ cl_path = ([], "Int") },[]), _
  1394. | TEnum({ e_path = ([], "Bool") },[]), _
  1395. | _, TInst({ cl_path = ([], "Float") },[])
  1396. | _, TInst({ cl_path = ([], "Int") },[])
  1397. | _, TInst( { cl_path = (["haxe"], "Int32") }, [] )
  1398. | _, TInst( { cl_path = (["haxe"], "Int64") }, [] )
  1399. | _, TEnum({ e_path = ([], "Bool") },[])
  1400. | TInst( { cl_kind = KTypeParameter }, [] ), _
  1401. | _, TInst( { cl_kind = KTypeParameter }, [] ) -> false
  1402. | _, _ -> true
  1403. in
  1404. let static = mk_static_field_access_infer (runtime_cl) (if is_ref then "refEq" else "eq") e1.epos [] in
  1405. { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tbool; epos=e1.epos }
  1406. end
  1407. )
  1408. (fun e e1 e2 ->
  1409. match may_nullable e1.etype, may_nullable e2.etype with
  1410. | Some t1, Some t2 ->
  1411. let t1, t2 = if is_string t1 || is_string t2 then
  1412. basic.tstring, basic.tstring
  1413. else if is_double t1 || is_double t2 then
  1414. basic.tfloat, basic.tfloat
  1415. else if is_int t1 || is_int t2 then
  1416. basic.tint, basic.tint
  1417. else t1, t2 in
  1418. { eexpr = TBinop(Ast.OpAdd, mk_cast t1 e1, mk_cast t2 e2); etype = e.etype; epos = e1.epos }
  1419. | _ ->
  1420. let static = mk_static_field_access_infer (runtime_cl) "plus" e1.epos [] in
  1421. mk_cast e.etype { eexpr = TCall(static, [e1; e2]); etype = t_dynamic; epos=e1.epos })
  1422. (fun e1 e2 ->
  1423. if is_string e1.etype then begin
  1424. { e1 with eexpr = TCall({ e1 with eexpr = TField(e1, "compareTo"); etype = TFun(["anotherString",false,gen.gcon.basic.tstring], gen.gcon.basic.tint) }, [ e2 ]); etype = gen.gcon.basic.tint }
  1425. end else begin
  1426. let static = mk_static_field_access_infer (runtime_cl) "compare" e1.epos [] in
  1427. { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tint; epos=e1.epos }
  1428. end));
  1429. FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func);
  1430. let base_exception = get_cl (get_type gen (["java"; "lang"], "Throwable")) in
  1431. let base_exception_t = TInst(base_exception, []) in
  1432. let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in
  1433. let hx_exception_t = TInst(hx_exception, []) in
  1434. TryCatchWrapper.configure gen
  1435. (
  1436. TryCatchWrapper.traverse gen
  1437. (fun t ->
  1438. match real_type t with
  1439. | TDynamic _ | TAnon _ | TMono _ | TLazy _ | TEnum _ -> true
  1440. | _ -> try unify t base_exception_t; false with | Unify_error _ -> true)
  1441. (fun throwexpr expr ->
  1442. let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) expr.epos in
  1443. { throwexpr with eexpr = TThrow { expr with eexpr = TCall(wrap_static, [expr]) }; etype = gen.gcon.basic.tvoid }
  1444. )
  1445. (fun v_to_unwrap pos ->
  1446. let local = mk_cast hx_exception_t { eexpr = TLocal(v_to_unwrap); etype = v_to_unwrap.v_type; epos = pos } in
  1447. { eexpr = TField(local, "obj"); epos = pos; etype = t_dynamic }
  1448. )
  1449. (fun rethrow ->
  1450. let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) rethrow.epos in
  1451. { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]) }; }
  1452. )
  1453. (base_exception_t)
  1454. (hx_exception_t)
  1455. (fun v e -> e)
  1456. );
  1457. let native_class_wrapper = get_cl (get_type gen (["haxe";"lang"], "NativeClassWrapper")) in
  1458. let get_typeof e =
  1459. { e with eexpr = TCall( { eexpr = TLocal( alloc_var "__typeof__" t_dynamic ); etype = t_dynamic; epos = e.epos }, [e] ) }
  1460. in
  1461. ClassInstance.configure gen (ClassInstance.traverse gen (fun e mt ->
  1462. if is_hxgen mt then begin
  1463. {
  1464. eexpr = TCall({
  1465. eexpr = TField(e, gen.gmk_internal_name "hx" "getClassStatic");
  1466. etype = TFun([], e.etype);
  1467. epos = e.epos
  1468. }, []);
  1469. etype = e.etype;
  1470. epos = e.epos;
  1471. }
  1472. end else begin
  1473. {
  1474. eexpr = TNew(native_class_wrapper, [], [ get_typeof e ]);
  1475. etype = e.etype;
  1476. epos = e.epos
  1477. }
  1478. end
  1479. ));
  1480. (*let v = alloc_var "$type_param" t_dynamic in*)
  1481. TypeParams.configure gen (fun ecall efield params elist ->
  1482. { ecall with eexpr = TCall(efield, elist) }
  1483. );
  1484. CastDetect.configure gen (CastDetect.default_implementation gen (Some (TEnum(empty_e, []))));
  1485. (*FollowAll.configure gen;*)
  1486. SwitchToIf.configure gen (SwitchToIf.traverse gen (fun e ->
  1487. match e.eexpr with
  1488. | TSwitch(cond, cases, def) ->
  1489. (match gen.gfollow#run_f cond.etype with
  1490. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  1491. | TInst({ cl_path = ([], "Int") },[])
  1492. | TInst({ cl_path = ([], "String") },[]) ->
  1493. (List.exists (fun (c,_) ->
  1494. List.exists (fun expr -> match expr.eexpr with | TConst _ -> false | _ -> true ) c
  1495. ) cases)
  1496. | _ -> true
  1497. )
  1498. | _ -> assert false
  1499. ) true );
  1500. let native_arr_cl = get_cl ( get_type gen (["java"], "NativeArray") ) in
  1501. ExpressionUnwrap.configure gen (ExpressionUnwrap.traverse gen (fun e -> Some { eexpr = TVars([mk_temp gen "expr" e.etype, Some e]); etype = gen.gcon.basic.tvoid; epos = e.epos }));
  1502. IntDivisionSynf.configure gen (IntDivisionSynf.default_implementation gen true);
  1503. UnreachableCodeEliminationSynf.configure gen (UnreachableCodeEliminationSynf.traverse gen true);
  1504. ArrayDeclSynf.configure gen (ArrayDeclSynf.default_implementation gen native_arr_cl);
  1505. let goto_special = alloc_var "__goto__" t_dynamic in
  1506. let label_special = alloc_var "__label__" t_dynamic in
  1507. SwitchBreakSynf.configure gen (SwitchBreakSynf.traverse gen
  1508. (fun e_loop n api ->
  1509. { e_loop with eexpr = TBlock( { eexpr = TCall( mk_local label_special e_loop.epos, [ mk_int gen n e_loop.epos ] ); etype = t_dynamic; epos = e_loop.epos } :: [e_loop] ) };
  1510. )
  1511. (fun e_break n api ->
  1512. { eexpr = TCall( mk_local goto_special e_break.epos, [ mk_int gen n e_break.epos ] ); etype = t_dynamic; epos = e_break.epos }
  1513. )
  1514. );
  1515. DefaultArguments.configure gen (DefaultArguments.traverse gen);
  1516. JavaSpecificSynf.configure gen (JavaSpecificSynf.traverse gen runtime_cl);
  1517. JavaSpecificESynf.configure gen (JavaSpecificESynf.traverse gen runtime_cl);
  1518. run_filters gen;
  1519. TypeParams.RenameTypeParameters.run gen;
  1520. let t = Common.timer "code generation" in
  1521. generate_modules_t gen "java" "src" change_path module_gen;
  1522. t()
  1523. (* end of configure function *)
  1524. let before_generate con =
  1525. List.iter (Codegen.fix_overrides con) con.types
  1526. let generate con =
  1527. let gen = new_ctx con in
  1528. let basic = con.basic in
  1529. (* make the basic functions in java *)
  1530. let basic_fns =
  1531. [
  1532. mk_class_field "equals" (TFun(["obj",false,t_dynamic], basic.tbool)) true Ast.null_pos (Method MethNormal) [];
  1533. mk_class_field "toString" (TFun([], basic.tstring)) true Ast.null_pos (Method MethNormal) [];
  1534. mk_class_field "hashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) [];
  1535. ] in
  1536. List.iter (fun cf -> gen.gbase_class_fields <- PMap.add cf.cf_name cf gen.gbase_class_fields) basic_fns;
  1537. try
  1538. configure gen
  1539. with | TypeNotFound path -> con.error ("Error. Module '" ^ (path_s path) ^ "' is required and was not included in build.") Ast.null_pos