genjava.ml 75 KB

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