genjava.ml 130 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195
  1. (*
  2. * Copyright (C)2005-2013 Haxe Foundation
  3. *
  4. * Permission is hereby granted, free of charge, to any person obtaining a
  5. * copy of this software and associated documentation files (the "Software"),
  6. * to deal in the Software without restriction, including without limitation
  7. * the rights to use, copy, modify, merge, publish, distribute, sublicense,
  8. * and/or sell copies of the Software, and to permit persons to whom the
  9. * Software is furnished to do so, subject to the following conditions:
  10. *
  11. * The above copyright notice and this permission notice shall be included in
  12. * all copies or substantial portions of the Software.
  13. *
  14. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15. * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16. * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  17. * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18. * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20. * DEALINGS IN THE SOFTWARE.
  21. *)
  22. open JData
  23. open Unix
  24. open Ast
  25. open Common
  26. open Gencommon
  27. open Gencommon.SourceWriter
  28. open Type
  29. open Printf
  30. open Option
  31. open ExtString
  32. let is_boxed_type t = match follow t with
  33. | TInst ({ cl_path = (["java";"lang"], "Boolean") }, [])
  34. | TInst ({ cl_path = (["java";"lang"], "Double") }, [])
  35. | TInst ({ cl_path = (["java";"lang"], "Integer") }, [])
  36. | TInst ({ cl_path = (["java";"lang"], "Byte") }, [])
  37. | TInst ({ cl_path = (["java";"lang"], "Short") }, [])
  38. | TInst ({ cl_path = (["java";"lang"], "Character") }, [])
  39. | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> true
  40. | _ -> false
  41. let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with
  42. | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool
  43. | TInst ({ cl_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat
  44. | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint
  45. | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) -> tbyte
  46. | TInst ({ cl_path = (["java";"lang"], "Short") }, []) -> tshort
  47. | TInst ({ cl_path = (["java";"lang"], "Character") }, []) -> tchar
  48. | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> tfloat
  49. | _ -> assert false
  50. let rec t_has_type_param t = match follow t with
  51. | TInst({ cl_kind = KTypeParameter _ }, []) -> true
  52. | TEnum(_, params)
  53. | TInst(_, params) -> List.exists t_has_type_param params
  54. | TFun(f,ret) -> t_has_type_param ret || List.exists (fun (_,_,t) -> t_has_type_param t) f
  55. | _ -> false
  56. let is_type_param t = match follow t with
  57. | TInst({ cl_kind = KTypeParameter _ }, _) -> true
  58. | _ -> false
  59. let rec t_has_type_param_shallow last t = match follow t with
  60. | TInst({ cl_kind = KTypeParameter _ }, []) -> true
  61. | TEnum(_, params)
  62. | TInst(_, params) when not last -> List.exists (t_has_type_param_shallow true) params
  63. | 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
  64. | _ -> false
  65. let is_java_basic_type t =
  66. match follow t with
  67. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  68. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  69. | TAbstract( { a_path = ([], "Single") }, [] )
  70. | TAbstract( { a_path = (["java"], ("Int8" | "Int16" | "Char16")) }, [] )
  71. | TInst( { cl_path = ([], "Int") }, [] ) | TAbstract( { a_path = ([], "Int") }, [] )
  72. | TInst( { cl_path = ([], "Float") }, [] ) | TAbstract( { a_path = ([], "Float") }, [] )
  73. | TEnum( { e_path = ([], "Bool") }, [] ) | TAbstract( { a_path = ([], "Bool") }, [] ) ->
  74. true
  75. | _ -> false
  76. let is_bool t =
  77. match follow t with
  78. | TEnum( { e_path = ([], "Bool") }, [] )
  79. | TAbstract ({ a_path = ([], "Bool") },[]) ->
  80. true
  81. | _ -> false
  82. let is_int_float gen t =
  83. match follow (gen.greal_type t) with
  84. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  85. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  86. | TInst( { cl_path = ([], "Int") }, [] ) | TAbstract( { a_path = ([], "Int") }, [] )
  87. | TInst( { cl_path = ([], "Float") }, [] ) | TAbstract( { a_path = ([], "Float") }, [] ) ->
  88. true
  89. | (TAbstract _ as t) when like_float t -> true
  90. | _ -> false
  91. let parse_explicit_iface =
  92. let regex = Str.regexp "\\." in
  93. let parse_explicit_iface str =
  94. let split = Str.split regex str in
  95. let rec get_iface split pack =
  96. match split with
  97. | clname :: fn_name :: [] -> fn_name, (List.rev pack, clname)
  98. | pack_piece :: tl -> get_iface tl (pack_piece :: pack)
  99. | _ -> assert false
  100. in
  101. get_iface split []
  102. in parse_explicit_iface
  103. let is_string t =
  104. match follow t with
  105. | TInst( { cl_path = ([], "String") }, [] ) -> true
  106. | _ -> false
  107. let is_cl t = match follow t with
  108. | TInst({ cl_path = ["java";"lang"],"Class" },_)
  109. | TAbstract({ a_path = [], ("Class"|"Enum") },_) -> true
  110. | TAnon(a) when is_some (anon_class t) -> true
  111. | _ -> false
  112. (* ******************************************* *)
  113. (* JavaSpecificESynf *)
  114. (* ******************************************* *)
  115. (*
  116. Some Java-specific syntax filters that must run before ExpressionUnwrap
  117. dependencies:
  118. It must run before ExprUnwrap, as it may not return valid Expr/Statement expressions
  119. It must run before ClassInstance, as it will detect expressions that need unchanged TTypeExpr
  120. It must run after CastDetect, as it changes casts
  121. It must run after TryCatchWrapper, to change Std.is() calls inside there
  122. *)
  123. module JavaSpecificESynf =
  124. struct
  125. let name = "java_specific_e"
  126. let priority = solve_deps name [ DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter CastDetect.priority; DAfter TryCatchWrapper.priority ]
  127. let get_cl_from_t t =
  128. match follow t with
  129. | TInst(cl,_) -> cl
  130. | _ -> assert false
  131. let traverse gen runtime_cl =
  132. let basic = gen.gcon.basic in
  133. let float_cl = get_cl ( get_type gen (["java";"lang"], "Double")) in
  134. let i8_md = ( get_type gen (["java";"lang"], "Byte")) in
  135. let i16_md = ( get_type gen (["java";"lang"], "Short")) in
  136. let i64_md = ( get_type gen (["java";"lang"], "Long")) in
  137. let c16_md = ( get_type gen (["java";"lang"], "Character")) in
  138. let f_md = ( get_type gen (["java";"lang"], "Float")) in
  139. let bool_md = get_type gen (["java";"lang"], "Boolean") in
  140. let is_var = alloc_var "__is__" t_dynamic in
  141. let rec run e =
  142. match e.eexpr with
  143. (* Math changes *)
  144. | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NaN" }) ) ->
  145. mk_static_field_access_infer float_cl "NaN" e.epos []
  146. | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NEGATIVE_INFINITY" }) ) ->
  147. mk_static_field_access_infer float_cl "NEGATIVE_INFINITY" e.epos []
  148. | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "POSITIVE_INFINITY" }) ) ->
  149. mk_static_field_access_infer float_cl "POSITIVE_INFINITY" e.epos []
  150. | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isNaN"}) ) ->
  151. mk_static_field_access_infer float_cl "_isNaN" e.epos []
  152. | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("ffloor" as f) }) ) } as fe), p)
  153. | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fceil" as f) }) ) } as fe), p) ->
  154. Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic (String.sub f 1 (String.length f - 1))) }, p) }
  155. | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fround") }) ) } as fe), p) ->
  156. Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic "rint") }, p) }
  157. | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "floor" }) ) }, _)
  158. | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "round" }) ) }, _)
  159. | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "ceil" }) ) }, _) ->
  160. mk_cast basic.tint (Type.map_expr run { e with etype = basic.tfloat })
  161. | TCall( ( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isFinite" }) ) } as efield ), [v]) ->
  162. { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "isFinite" efield.epos [], [run v] ) }
  163. (* end of math changes *)
  164. (* Std.is() *)
  165. | TCall(
  166. { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is" })) },
  167. [ obj; { eexpr = TTypeExpr(md) } ]
  168. ) ->
  169. let mk_is is_basic obj md =
  170. let obj = if is_basic then mk_cast t_dynamic obj else obj in
  171. { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [
  172. run obj;
  173. { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos }
  174. ] ) }
  175. in
  176. (match follow_module follow md with
  177. | TClassDecl({ cl_path = ([], "Float") })
  178. | TAbstractDecl({ a_path = ([], "Float") }) ->
  179. {
  180. eexpr = TCall(
  181. mk_static_field_access_infer runtime_cl "isDouble" e.epos [],
  182. [ run obj ]
  183. );
  184. etype = basic.tbool;
  185. epos = e.epos
  186. }
  187. | TClassDecl{ cl_path = ([], "Int") }
  188. | TAbstractDecl{ a_path = ([], "Int") } ->
  189. {
  190. eexpr = TCall(
  191. mk_static_field_access_infer runtime_cl "isInt" e.epos [],
  192. [ run obj ]
  193. );
  194. etype = basic.tbool;
  195. epos = e.epos
  196. }
  197. | TAbstractDecl{ a_path = ([], "Bool") }
  198. | TEnumDecl{ e_path = ([], "Bool") } ->
  199. mk_is true obj bool_md
  200. | TAbstractDecl{ a_path = ([], "Single") } ->
  201. mk_is true obj f_md
  202. | TAbstractDecl{ a_path = (["java"], "Int8") } ->
  203. mk_is true obj i8_md
  204. | TAbstractDecl{ a_path = (["java"], "Int16") } ->
  205. mk_is true obj i16_md
  206. | TAbstractDecl{ a_path = (["java"], "Char16") } ->
  207. mk_is true obj c16_md
  208. | TClassDecl{ cl_path = (["haxe"], "Int64") } ->
  209. mk_is true obj i64_md
  210. | TAbstractDecl{ a_path = ([], "Dynamic") }
  211. | TClassDecl{ cl_path = ([], "Dynamic") } ->
  212. (match obj.eexpr with
  213. | TLocal _ | TConst _ -> { e with eexpr = TConst(TBool true) }
  214. | _ -> { e with eexpr = TBlock([run obj; { e with eexpr = TConst(TBool true) }]) }
  215. )
  216. | _ ->
  217. mk_is false obj md
  218. )
  219. (* end Std.is() *)
  220. | _ -> Type.map_expr run e
  221. in
  222. run
  223. let configure gen (mapping_func:texpr->texpr) =
  224. let map e = Some(mapping_func e) in
  225. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  226. end;;
  227. (* ******************************************* *)
  228. (* JavaSpecificSynf *)
  229. (* ******************************************* *)
  230. (*
  231. Some Java-specific syntax filters that can run after ExprUnwrap
  232. dependencies:
  233. Runs after ExprUnwarp
  234. *)
  235. module JavaSpecificSynf =
  236. struct
  237. let name = "java_specific"
  238. let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DBefore IntDivisionSynf.priority ]
  239. let java_hash s =
  240. let h = ref Int32.zero in
  241. let thirtyone = Int32.of_int 31 in
  242. for i = 0 to String.length s - 1 do
  243. h := Int32.add (Int32.mul thirtyone !h) (Int32.of_int (int_of_char (String.unsafe_get s i)));
  244. done;
  245. !h
  246. let rec is_final_return_expr is_switch e =
  247. let is_final_return_expr = is_final_return_expr is_switch in
  248. match e.eexpr with
  249. | TReturn _
  250. | TThrow _ -> true
  251. (* this is hack to not use 'break' on switch cases *)
  252. | TLocal { v_name = "__fallback__" } when is_switch -> true
  253. | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> true
  254. | TParenthesis p | TMeta (_,p) -> is_final_return_expr p
  255. | TBlock bl -> is_final_return_block is_switch bl
  256. | TSwitch (_, el_e_l, edef) ->
  257. List.for_all (fun (_,e) -> is_final_return_expr e) el_e_l && Option.map_default is_final_return_expr false edef
  258. (* | TMatch (_, _, il_vl_e_l, edef) ->
  259. List.for_all (fun (_,_,e) -> is_final_return_expr e)il_vl_e_l && Option.map_default is_final_return_expr false edef *)
  260. | TIf (_,eif, Some eelse) ->
  261. is_final_return_expr eif && is_final_return_expr eelse
  262. | TFor (_,_,e) ->
  263. is_final_return_expr e
  264. | TWhile (_,e,_) ->
  265. is_final_return_expr e
  266. | TFunction tf ->
  267. is_final_return_expr tf.tf_expr
  268. | TTry (e, ve_l) ->
  269. is_final_return_expr e && List.for_all (fun (_,e) -> is_final_return_expr e) ve_l
  270. | _ -> false
  271. and is_final_return_block is_switch el =
  272. match el with
  273. | [] -> false
  274. | final :: [] -> is_final_return_expr is_switch final
  275. | hd :: tl -> is_final_return_block is_switch tl
  276. let is_null e = match e.eexpr with | TConst(TNull) -> true | _ -> false
  277. let rec is_equatable gen t =
  278. match follow t with
  279. | TInst(cl,_) ->
  280. if cl.cl_path = (["haxe";"lang"], "IEquatable") then
  281. true
  282. else
  283. List.exists (fun (cl,p) -> is_equatable gen (TInst(cl,p))) cl.cl_implements
  284. || (match cl.cl_super with | Some(cl,p) -> is_equatable gen (TInst(cl,p)) | None -> false)
  285. | _ -> false
  286. (*
  287. Changing string switch
  288. will take an expression like
  289. switch(str)
  290. {
  291. case "a":
  292. case "b":
  293. }
  294. and modify it to:
  295. {
  296. var execute_def = true;
  297. switch(str.hashCode())
  298. {
  299. case (hashcode of a):
  300. if (str == "a")
  301. {
  302. execute_def = false;
  303. ..code here
  304. } //else if (str == otherVariableWithSameHashCode) {
  305. ...
  306. }
  307. ...
  308. }
  309. if (execute_def)
  310. {
  311. ..default code
  312. }
  313. }
  314. this might actually be slower in some cases than a if/else approach, but it scales well and as a bonus,
  315. hashCode in java are cached, so we only have the performance hit once to cache it.
  316. *)
  317. let change_string_switch gen eswitch e1 ecases edefault =
  318. let basic = gen.gcon.basic in
  319. let is_final_ret = is_final_return_expr false eswitch in
  320. let has_default = is_some edefault in
  321. let block = ref [] in
  322. let local = match e1.eexpr with
  323. | TLocal _ -> e1
  324. | _ ->
  325. let var = mk_temp gen "svar" e1.etype in
  326. let added = { e1 with eexpr = TVar(var, Some(e1)); etype = basic.tvoid } in
  327. let local = mk_local var e1.epos in
  328. block := added :: !block;
  329. local
  330. in
  331. let execute_def_var = mk_temp gen "executeDef" gen.gcon.basic.tbool in
  332. let execute_def = mk_local execute_def_var e1.epos in
  333. 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
  334. let hash_cache = ref None in
  335. let local_hashcode = ref { local with
  336. eexpr = TCall({ local with
  337. eexpr = TField(local, FDynamic "hashCode");
  338. etype = TFun([], basic.tint);
  339. }, []);
  340. etype = basic.tint
  341. } in
  342. let get_hash_cache () =
  343. match !hash_cache with
  344. | Some c -> c
  345. | None ->
  346. let var = mk_temp gen "hash" basic.tint in
  347. let cond = !local_hashcode in
  348. block := { eexpr = TVar(var, Some cond); etype = basic.tvoid; epos = local.epos } :: !block;
  349. let local = mk_local var local.epos in
  350. local_hashcode := local;
  351. hash_cache := Some local;
  352. local
  353. in
  354. let has_case = ref false in
  355. (* first we need to reorder all cases so all collisions are close to each other *)
  356. let get_str e = match e.eexpr with | TConst(TString s) -> s | _ -> assert false in
  357. let has_conflict = ref false in
  358. let rec reorder_cases unordered ordered =
  359. match unordered with
  360. | [] -> ordered
  361. | (el, e) :: tl ->
  362. let current = Hashtbl.create 1 in
  363. List.iter (fun e ->
  364. let str = get_str e in
  365. let hash = java_hash str in
  366. Hashtbl.add current hash true
  367. ) el;
  368. let rec extract_fields cases found_cases ret_cases =
  369. match cases with
  370. | [] -> found_cases, ret_cases
  371. | (el, e) :: tl ->
  372. if List.exists (fun e -> Hashtbl.mem current (java_hash (get_str e)) ) el then begin
  373. has_conflict := true;
  374. List.iter (fun e -> Hashtbl.add current (java_hash (get_str e)) true) el;
  375. extract_fields tl ( (el, e) :: found_cases ) ret_cases
  376. end else
  377. extract_fields tl found_cases ( (el, e) :: ret_cases )
  378. in
  379. let found, remaining = extract_fields tl [] [] in
  380. let ret = if found <> [] then
  381. let ret = List.sort (fun (e1,_) (e2,_) -> compare (List.length e2) (List.length e1) ) ( (el, e) :: found ) in
  382. let rec loop ret acc =
  383. match ret with
  384. | (el, e) :: ( (_,_) :: _ as tl ) -> loop tl ( (true, el, e) :: acc )
  385. | (el, e) :: [] -> ( (false, el, e) :: acc )
  386. | _ -> assert false
  387. in
  388. List.rev (loop ret [])
  389. else
  390. (false, el, e) :: []
  391. in
  392. reorder_cases remaining (ordered @ ret)
  393. in
  394. let already_in_cases = Hashtbl.create 0 in
  395. let change_case (has_fallback, el, e) =
  396. let conds, el = List.fold_left (fun (conds,el) e ->
  397. has_case := true;
  398. match e.eexpr with
  399. | TConst(TString s) ->
  400. let hashed = java_hash s in
  401. let equals_test = {
  402. eexpr = TCall({ e with eexpr = TField(local, FDynamic "equals"); etype = TFun(["obj",false,t_dynamic],basic.tbool) }, [ e ]);
  403. etype = basic.tbool;
  404. epos = e.epos
  405. } in
  406. let hashed_expr = { eexpr = TConst(TInt hashed); etype = basic.tint; epos = e.epos } in
  407. let hashed_exprs = if !has_conflict then begin
  408. if Hashtbl.mem already_in_cases hashed then
  409. el
  410. else begin
  411. Hashtbl.add already_in_cases hashed true;
  412. hashed_expr :: el
  413. end
  414. end else hashed_expr :: el in
  415. let conds = match conds with
  416. | None -> equals_test
  417. | Some c ->
  418. (*
  419. if there is more than one case, we should test first if hash equals to the one specified.
  420. This way we can save a heavier string compare
  421. *)
  422. let equals_test = mk_paren {
  423. eexpr = TBinop(Ast.OpBoolAnd, { eexpr = TBinop(Ast.OpEq, get_hash_cache(), hashed_expr); etype = basic.tbool; epos = e.epos }, equals_test);
  424. etype = basic.tbool;
  425. epos = e.epos;
  426. } in
  427. { eexpr = TBinop(Ast.OpBoolOr, equals_test, c); etype = basic.tbool; epos = e1.epos }
  428. in
  429. Some conds, hashed_exprs
  430. | _ -> assert false
  431. ) (None,[]) el in
  432. let e = if has_default then Type.concat execute_def_set e else e in
  433. let e = if !has_conflict then Type.concat e { e with eexpr = TBreak; etype = basic.tvoid } else e in
  434. let e = {
  435. eexpr = TIf(get conds, e, None);
  436. etype = basic.tvoid;
  437. epos = e.epos
  438. } in
  439. let e = if has_fallback then { e with eexpr = TBlock([ e; mk_local (alloc_var "__fallback__" t_dynamic) e.epos]) } else e in
  440. (el, e)
  441. in
  442. let switch = { eswitch with
  443. eexpr = TSwitch(!local_hashcode, List.map change_case (reorder_cases ecases []), None);
  444. } in
  445. (if !has_case then begin
  446. (if has_default then block := { e1 with eexpr = TVar(execute_def_var, Some({ e1 with eexpr = TConst(TBool true); etype = basic.tbool })); etype = basic.tvoid } :: !block);
  447. block := switch :: !block
  448. end);
  449. (match edefault with
  450. | None -> ()
  451. | Some edef when not !has_case ->
  452. block := edef :: !block
  453. | Some edef ->
  454. 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
  455. block := { edef with eexpr = TIf(execute_def, edef, eelse); etype = basic.tvoid } :: !block
  456. );
  457. { eswitch with eexpr = TBlock(List.rev !block) }
  458. let get_cl_from_t t =
  459. match follow t with
  460. | TInst(cl,_) -> cl
  461. | _ -> assert false
  462. let traverse gen runtime_cl =
  463. let basic = gen.gcon.basic in
  464. let tchar = mt_to_t_dyn ( get_type gen (["java"], "Char16") ) in
  465. let tbyte = mt_to_t_dyn ( get_type gen (["java"], "Int8") ) in
  466. let tshort = mt_to_t_dyn ( get_type gen (["java"], "Int16") ) in
  467. let tsingle = mt_to_t_dyn ( get_type gen ([], "Single") ) in
  468. let string_ext = get_cl ( get_type gen (["haxe";"lang"], "StringExt")) in
  469. let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false in
  470. let rec run e =
  471. match e.eexpr with
  472. (* for new NativeArray<T> issues *)
  473. | TNew(({ cl_path = (["java"], "NativeArray") } as cl), [t], el) when is_type_param t ->
  474. mk_cast (TInst(cl,[t])) (mk_cast t_dynamic ({ e with eexpr = TNew(cl, [t_empty], List.map run el) }))
  475. (* Std.int() *)
  476. | TCall(
  477. { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" })) },
  478. [obj]
  479. ) ->
  480. run (mk_cast basic.tint obj)
  481. (* end Std.int() *)
  482. | TField( ef, FInstance({ cl_path = ([], "String") }, { cf_name = "length" }) ) ->
  483. { e with eexpr = TCall(Type.map_expr run e, []) }
  484. | TField( ef, field ) when field_name field = "length" && is_string ef.etype ->
  485. { e with eexpr = TCall(Type.map_expr run e, []) }
  486. | TCall( ( { eexpr = TField(ef, field) } as efield ), args ) when is_string ef.etype && String.get (field_name field) 0 = '_' ->
  487. let field = field_name field in
  488. { e with eexpr = TCall({ efield with eexpr = TField(run ef, FDynamic (String.sub field 1 ( (String.length field) - 1)) )}, List.map run args) }
  489. | TCall( ( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, field )) } as efield ), args ) ->
  490. let field = field.cf_name in
  491. (match field with
  492. | "charAt" | "charCodeAt" | "split" | "indexOf"
  493. | "lastIndexOf" | "substring" | "substr" ->
  494. { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) }
  495. | _ ->
  496. { e with eexpr = TCall(run efield, List.map run args) }
  497. )
  498. (* | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("toString") })) }, [] ) ->
  499. run ef *)
  500. | TCast(expr, m) when is_boxed_type e.etype ->
  501. (* let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with *)
  502. run { e with etype = unboxed_type gen e.etype tbyte tshort tchar tsingle }
  503. | TCast(expr, _) when is_bool e.etype ->
  504. {
  505. eexpr = TCall(
  506. mk_static_field_access_infer runtime_cl "toBool" expr.epos [],
  507. [ run expr ]
  508. );
  509. etype = basic.tbool;
  510. epos = e.epos
  511. }
  512. | TCast(expr, _) when is_int_float gen e.etype && not (is_int_float gen expr.etype) ->
  513. let needs_cast = match gen.gfollow#run_f e.etype with
  514. | TInst _ -> false
  515. | _ -> true
  516. in
  517. let fun_name = if like_int e.etype then "toInt" else "toDouble" in
  518. let ret = {
  519. eexpr = TCall(
  520. mk_static_field_access_infer runtime_cl fun_name expr.epos [],
  521. [ run expr ]
  522. );
  523. etype = if fun_name = "toDouble" then basic.tfloat else basic.tint;
  524. epos = expr.epos
  525. } in
  526. if needs_cast then mk_cast e.etype ret else ret
  527. (*| TCast(expr, c) when is_int_float gen e.etype ->
  528. (* cases when float x = (float) (java.lang.Double val); *)
  529. (* FIXME: this fix is broken since it will fail on cases where float x = (float) (java.lang.Float val) or similar. FIX THIS *)
  530. let need_second_cast = match gen.gfollow#run_f e.etype with
  531. | TInst _ -> false
  532. | _ -> true
  533. in
  534. if need_second_cast then { e with eexpr = TCast(mk_cast (follow e.etype) (run expr), c) } else Type.map_expr run e*)
  535. | TBinop( (Ast.OpAssignOp OpAdd as op), e1, e2)
  536. | TBinop( (Ast.OpAdd as op), e1, e2) when is_string e.etype || is_string e1.etype || is_string e2.etype ->
  537. let is_assign = match op with Ast.OpAssignOp _ -> true | _ -> false in
  538. let mk_to_string e = { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" e.epos [], [run e] ); etype = gen.gcon.basic.tstring } in
  539. let check_cast e = match gen.greal_type e.etype with
  540. | TDynamic _
  541. | TAbstract({ a_path = ([], "Float") }, [])
  542. | TAbstract({ a_path = ([], "Single") }, []) ->
  543. mk_to_string e
  544. | _ -> run e
  545. in
  546. { e with eexpr = TBinop(op, (if is_assign then run e1 else check_cast e1), check_cast e2) }
  547. | TCast(expr, _) when is_string e.etype ->
  548. { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) }
  549. | TSwitch(cond, ecases, edefault) when is_string cond.etype ->
  550. (*let change_string_switch gen eswitch e1 ecases edefault =*)
  551. change_string_switch gen e (run cond) (List.map (fun (el,e) -> (el, run e)) ecases) (Option.map run edefault)
  552. | TBinop( (Ast.OpNotEq as op), e1, e2)
  553. | 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) ->
  554. let static = mk_static_field_access_infer (runtime_cl) "valEq" e1.epos [] in
  555. let eret = { eexpr = TCall(static, [run e1; run e2]); etype = gen.gcon.basic.tbool; epos=e.epos } in
  556. if op = Ast.OpNotEq then { eret with eexpr = TUnop(Ast.Not, Ast.Prefix, eret) } else eret
  557. | TBinop( (Ast.OpNotEq | Ast.OpEq as op), e1, e2) when is_cl e1.etype && is_cl e2.etype ->
  558. { e with eexpr = TBinop(op, mk_cast t_empty (run e1), mk_cast t_empty (run e2)) }
  559. | _ -> Type.map_expr run e
  560. in
  561. run
  562. let configure gen (mapping_func:texpr->texpr) =
  563. (if java_hash "Testing string hashCode implementation from haXe" <> (Int32.of_int 545883604) then assert false);
  564. let map e = Some(mapping_func e) in
  565. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  566. end;;
  567. 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 *)
  568. 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? *)
  569. let strict_mode = ref false (* strict mode is so we can check for unexpected information *)
  570. (* reserved c# words *)
  571. let reserved = let res = Hashtbl.create 120 in
  572. List.iter (fun lst -> Hashtbl.add res lst ("_" ^ lst)) ["abstract"; "assert"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class";
  573. "const"; "continue"; "default"; "do"; "double"; "else"; "enum"; "extends"; "final";
  574. "false"; "finally"; "float"; "for"; "goto"; "if"; "implements"; "import"; "instanceof"; "int";
  575. "interface"; "long"; "native"; "new"; "null"; "package"; "private"; "protected"; "public"; "return"; "short";
  576. "static"; "strictfp"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; "transient"; "true"; "try";
  577. "void"; "volatile"; "while"; ];
  578. res
  579. let dynamic_anon = TAnon( { a_fields = PMap.empty; a_status = ref Closed } )
  580. let rec get_class_modifiers meta cl_type cl_access cl_modifiers =
  581. match meta with
  582. | [] -> cl_type,cl_access,cl_modifiers
  583. (*| (Meta.Struct,[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers*)
  584. | (Meta.Protected,[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers
  585. | (Meta.Internal,[],_) :: meta -> get_class_modifiers meta cl_type "" cl_modifiers
  586. (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers)
  587. | (Meta.Static,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("static" :: cl_modifiers) TODO: support those types *)
  588. | (Meta.Final,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("final" :: cl_modifiers)
  589. | _ :: meta -> get_class_modifiers meta cl_type cl_access cl_modifiers
  590. let rec get_fun_modifiers meta access modifiers =
  591. match meta with
  592. | [] -> access,modifiers
  593. | (Meta.Protected,[],_) :: meta -> get_fun_modifiers meta "protected" modifiers
  594. | (Meta.Internal,[],_) :: meta -> get_fun_modifiers meta "" modifiers
  595. (*| (Meta.ReadOnly,[],_) :: meta -> get_fun_modifiers meta access ("readonly" :: modifiers)*)
  596. (*| (Meta.Unsafe,[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)*)
  597. | (Meta.Volatile,[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers)
  598. | (Meta.Transient,[],_) :: meta -> get_fun_modifiers meta access ("transient" :: modifiers)
  599. | (Meta.Native,[],_) :: meta -> get_fun_modifiers meta access ("native" :: modifiers)
  600. | _ :: meta -> get_fun_modifiers meta access modifiers
  601. (* this was the way I found to pass the generator context to be accessible across all functions here *)
  602. (* so 'configure' is almost 'top-level' and will have all functions needed to make this work *)
  603. let configure gen =
  604. let basic = gen.gcon.basic in
  605. let fn_cl = get_cl (get_type gen (["haxe";"lang"],"Function")) in
  606. let runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in
  607. (*let string_ref = get_cl ( get_type gen (["haxe";"lang"], "StringRefl")) in*)
  608. let ti64 = match ( get_type gen (["haxe";"_Int64"], "NativeInt64") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
  609. let has_tdynamic params =
  610. List.exists (fun e -> match run_follow gen e with | TDynamic _ -> true | _ -> false) params
  611. in
  612. (*
  613. The type parameters always need to be changed to their boxed counterparts
  614. *)
  615. let change_param_type md params =
  616. match md with
  617. | TClassDecl( { cl_path = (["java"], "NativeArray") } ) -> params
  618. | _ ->
  619. match params with
  620. | [] -> []
  621. | _ ->
  622. if has_tdynamic params then List.map (fun _ -> t_dynamic) params else
  623. List.map (fun t ->
  624. let f_t = gen.gfollow#run_f t in
  625. match f_t with
  626. | TEnum ({ e_path = ([], "Bool") }, [])
  627. | TAbstract ({ a_path = ([], "Bool") },[])
  628. | TInst ({ cl_path = ([],"Float") },[])
  629. | TAbstract ({ a_path = ([],"Float") },[])
  630. | TInst ({ cl_path = ["haxe"],"Int32" },[])
  631. | TInst ({ cl_path = ["haxe"],"Int64" },[])
  632. | TInst ({ cl_path = ([],"Int") },[])
  633. | TAbstract ({ a_path = ([],"Int") },[])
  634. | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
  635. | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[])
  636. | TType ({ t_path = ["java"],"Int8" },[])
  637. | TAbstract ({ a_path = ["java"],"Int8" },[])
  638. | TType ({ t_path = ["java"],"Int16" },[])
  639. | TAbstract ({ a_path = ["java"],"Int16" },[])
  640. | TType ({ t_path = ["java"],"Char16" },[])
  641. | TAbstract ({ a_path = ["java"],"Char16" },[])
  642. | TType ({ t_path = [],"Single" },[])
  643. | TAbstract ({ a_path = [],"Single" },[]) ->
  644. basic.tnull f_t
  645. (*| TType ({ t_path = [], "Null"*)
  646. | TInst (cl, ((_ :: _) as p)) ->
  647. TInst(cl, List.map (fun _ -> t_dynamic) p)
  648. | TEnum (e, ((_ :: _) as p)) ->
  649. TEnum(e, List.map (fun _ -> t_dynamic) p)
  650. | _ -> t
  651. ) params
  652. in
  653. let change_clname name =
  654. String.map (function | '$' -> '.' | c -> c) name
  655. in
  656. let change_id name = try Hashtbl.find reserved name with | Not_found -> name in
  657. let rec change_ns ns = match ns with
  658. | [] -> ["haxe"; "root"]
  659. | _ -> List.map change_id ns
  660. in
  661. let change_field = change_id in
  662. let write_id w name = write w (change_id name) in
  663. let write_field w name = write w (change_field name) in
  664. gen.gfollow#add ~name:"follow_basic" (fun t -> match t with
  665. | TEnum ({ e_path = ([], "Bool") }, [])
  666. | TAbstract ({ a_path = ([], "Bool") },[])
  667. | TEnum ({ e_path = ([], "Void") }, [])
  668. | TAbstract ({ a_path = ([], "Void") },[])
  669. | TInst ({ cl_path = ([],"Float") },[])
  670. | TAbstract ({ a_path = ([],"Float") },[])
  671. | TInst ({ cl_path = ([],"Int") },[])
  672. | TAbstract ({ a_path = ([],"Int") },[])
  673. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  674. | TInst( { cl_path = (["haxe"], "Int64") }, [] )
  675. | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
  676. | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[])
  677. | TType ({ t_path = ["java"],"Int8" },[])
  678. | TAbstract ({ a_path = ["java"],"Int8" },[])
  679. | TType ({ t_path = ["java"],"Int16" },[])
  680. | TAbstract ({ a_path = ["java"],"Int16" },[])
  681. | TType ({ t_path = ["java"],"Char16" },[])
  682. | TAbstract ({ a_path = ["java"],"Char16" },[])
  683. | TType ({ t_path = [],"Single" },[])
  684. | TAbstract ({ a_path = [],"Single" },[])
  685. | TType ({ t_path = [],"Null" },[_]) -> Some t
  686. | TAbstract ({ a_impl = Some _ } as a, pl) ->
  687. Some (gen.gfollow#run_f ( Codegen.Abstract.get_underlying_type a pl) )
  688. | TAbstract( { a_path = ([], "EnumValue") }, _ )
  689. | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic
  690. | _ -> None);
  691. let change_path path = (change_ns (fst path), change_clname (snd path)) in
  692. let path_s path = match path with
  693. | (ns,clname) -> path_s (change_ns ns, change_clname clname)
  694. in
  695. let cl_cl = get_cl (get_type gen (["java";"lang"],"Class")) in
  696. let rec real_type t =
  697. let t = gen.gfollow#run_f t in
  698. match t with
  699. | TAbstract ({ a_impl = Some _ } as a, pl) ->
  700. real_type (Codegen.Abstract.get_underlying_type a pl)
  701. | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint
  702. | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64
  703. | TAbstract( { a_path = ([], "Class") }, p )
  704. | TAbstract( { a_path = ([], "Enum") }, p )
  705. | TInst( { cl_path = ([], "Class") }, p )
  706. | TInst( { cl_path = ([], "Enum") }, p ) -> TInst(cl_cl,p)
  707. | TEnum(e,params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
  708. | TInst(c,params) when Meta.has Meta.Enum c.cl_meta ->
  709. TInst(c, List.map (fun _ -> t_dynamic) params)
  710. | TInst _ -> t
  711. | TType({ t_path = ([], "Null") }, [t]) when is_java_basic_type t -> t_dynamic
  712. | TType({ t_path = ([], "Null") }, [t]) ->
  713. (match follow t with
  714. | TInst( { cl_kind = KTypeParameter _ }, []) ->
  715. (* t_dynamic *)
  716. real_type t
  717. | _ -> real_type t
  718. )
  719. | TType _ | TAbstract _ -> t
  720. | TAnon (anon) -> (match !(anon.a_status) with
  721. | Statics _ | EnumStatics _ | AbstractStatics _ -> t
  722. | _ -> t_dynamic)
  723. | TFun _ -> TInst(fn_cl,[])
  724. | _ -> t_dynamic
  725. in
  726. let scope = ref PMap.empty in
  727. let imports = ref [] in
  728. let clear_scope () =
  729. scope := PMap.empty;
  730. imports := [];
  731. in
  732. let add_scope name =
  733. scope := PMap.add name () !scope
  734. in
  735. let add_import pos path =
  736. let name = snd path in
  737. let rec loop = function
  738. | (pack, n) :: _ when name = n ->
  739. if path <> (pack,n) then
  740. gen.gcon.error ("This expression cannot be generated because " ^ path_s path ^ " is shadowed by the current scope and ") pos
  741. | _ :: tl ->
  742. loop tl
  743. | [] ->
  744. (* add import *)
  745. imports := path :: !imports
  746. in
  747. loop !imports
  748. in
  749. let path_s_import pos path = match path with
  750. | [], name when PMap.mem name !scope ->
  751. gen.gcon.error ("This expression cannot be generated because " ^ name ^ " is shadowed by the current scope") pos;
  752. name
  753. | pack1 :: _, name when PMap.mem pack1 !scope -> (* exists in scope *)
  754. add_import pos path;
  755. (* check if name exists in scope *)
  756. if PMap.mem name !scope then
  757. gen.gcon.error ("This expression cannot be generated because " ^ pack1 ^ " and " ^ name ^ " are both shadowed by the current scope") pos;
  758. name
  759. | _ -> path_s path
  760. in
  761. let is_dynamic t = match real_type t with
  762. | TMono _ | TDynamic _
  763. | TInst({ cl_kind = KTypeParameter _ }, _) -> true
  764. | TAnon anon ->
  765. (match !(anon.a_status) with
  766. | EnumStatics _ | Statics _ | AbstractStatics _ -> false
  767. | _ -> true
  768. )
  769. | _ -> false
  770. in
  771. let rec t_s pos t =
  772. match real_type t with
  773. (* basic types *)
  774. | TEnum ({ e_path = ([], "Bool") }, [])
  775. | TAbstract ({ a_path = ([], "Bool") },[]) -> "boolean"
  776. | TEnum ({ e_path = ([], "Void") }, [])
  777. | TAbstract ({ a_path = ([], "Void") },[]) ->
  778. path_s_import pos (["java";"lang"], "Object")
  779. | TInst ({ cl_path = ([],"Float") },[])
  780. | TAbstract ({ a_path = ([],"Float") },[]) -> "double"
  781. | TInst ({ cl_path = ([],"Int") },[])
  782. | TAbstract ({ a_path = ([],"Int") },[]) -> "int"
  783. | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
  784. | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "long"
  785. | TType ({ t_path = ["java"],"Int8" },[])
  786. | TAbstract ({ a_path = ["java"],"Int8" },[]) -> "byte"
  787. | TType ({ t_path = ["java"],"Int16" },[])
  788. | TAbstract ({ a_path = ["java"],"Int16" },[]) -> "short"
  789. | TType ({ t_path = ["java"],"Char16" },[])
  790. | TAbstract ({ a_path = ["java"],"Char16" },[]) -> "char"
  791. | TType ({ t_path = [],"Single" },[])
  792. | TAbstract ({ a_path = [],"Single" },[]) -> "float"
  793. | TInst ({ cl_path = ["haxe"],"Int32" },[])
  794. | TAbstract ({ a_path = ["haxe"],"Int32" },[]) -> "int"
  795. | TInst ({ cl_path = ["haxe"],"Int64" },[])
  796. | TAbstract ({ a_path = ["haxe"],"Int64" },[]) -> "long"
  797. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  798. let rec check_t_s t =
  799. match real_type t with
  800. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  801. (check_t_s param) ^ "[]"
  802. | _ -> t_s pos (run_follow gen t)
  803. in
  804. (check_t_s param) ^ "[]"
  805. (* end of basic types *)
  806. | TInst ({ cl_kind = KTypeParameter _; cl_path=p }, []) -> snd p
  807. | TAbstract ({ a_path = [], "Dynamic" },[]) ->
  808. path_s_import pos (["java";"lang"], "Object")
  809. | TMono r -> (match !r with | None -> "java.lang.Object" | Some t -> t_s pos (run_follow gen t))
  810. | TInst ({ cl_path = [], "String" }, []) ->
  811. path_s_import pos (["java";"lang"], "String")
  812. | TAbstract ({ a_path = [], "Class" }, [p]) | TAbstract ({ a_path = [], "Enum" }, [p])
  813. | TInst ({ cl_path = [], "Class" }, [p]) | TInst ({ cl_path = [], "Enum" }, [p]) ->
  814. path_param_s pos (TClassDecl cl_cl) (["java";"lang"], "Class") [p]
  815. | TAbstract ({ a_path = [], "Class" }, _) | TAbstract ({ a_path = [], "Enum" }, _)
  816. | TInst ({ cl_path = [], "Class" }, _) | TInst ({ cl_path = [], "Enum" }, _) ->
  817. path_s_import pos (["java";"lang"], "Class")
  818. | TEnum ({e_path = p}, _) ->
  819. path_s_import pos p
  820. | TInst (({cl_path = p;} as cl), _) when Meta.has Meta.Enum cl.cl_meta ->
  821. path_s_import pos p
  822. | TInst (({cl_path = p;} as cl), params) -> (path_param_s pos (TClassDecl cl) p params)
  823. | TType (({t_path = p;} as t), params) -> (path_param_s pos (TTypeDecl t) p params)
  824. | TAnon (anon) ->
  825. (match !(anon.a_status) with
  826. | Statics _ | EnumStatics _ | AbstractStatics _ ->
  827. path_s_import pos (["java";"lang"], "Class")
  828. | _ ->
  829. path_s_import pos (["java";"lang"], "Object"))
  830. | TDynamic _ ->
  831. path_s_import pos (["java";"lang"], "Object")
  832. (* No Lazy type nor Function type made. That's because function types will be at this point be converted into other types *)
  833. | _ -> 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) ^ " ]"
  834. and param_t_s pos t =
  835. match run_follow gen t with
  836. | TEnum ({ e_path = ([], "Bool") }, [])
  837. | TAbstract ({ a_path = ([], "Bool") },[]) ->
  838. path_s_import pos (["java";"lang"], "Boolean")
  839. | TInst ({ cl_path = ([],"Float") },[])
  840. | TAbstract ({ a_path = ([],"Float") },[]) ->
  841. path_s_import pos (["java";"lang"], "Double")
  842. | TInst ({ cl_path = ([],"Int") },[])
  843. | TAbstract ({ a_path = ([],"Int") },[]) ->
  844. path_s_import pos (["java";"lang"], "Integer")
  845. | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
  846. | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) ->
  847. path_s_import pos (["java";"lang"], "Long")
  848. | TInst ({ cl_path = ["haxe"],"Int64" },[])
  849. | TAbstract ({ a_path = ["haxe"],"Int64" },[]) ->
  850. path_s_import pos (["java";"lang"], "Long")
  851. | TInst ({ cl_path = ["haxe"],"Int32" },[])
  852. | TAbstract ({ a_path = ["haxe"],"Int32" },[]) ->
  853. path_s_import pos (["java";"lang"], "Integer")
  854. | TType ({ t_path = ["java"],"Int8" },[])
  855. | TAbstract ({ a_path = ["java"],"Int8" },[]) ->
  856. path_s_import pos (["java";"lang"], "Byte")
  857. | TType ({ t_path = ["java"],"Int16" },[])
  858. | TAbstract ({ a_path = ["java"],"Int16" },[]) ->
  859. path_s_import pos (["java";"lang"], "Short")
  860. | TType ({ t_path = ["java"],"Char16" },[])
  861. | TAbstract ({ a_path = ["java"],"Char16" },[]) ->
  862. path_s_import pos (["java";"lang"], "Character")
  863. | TType ({ t_path = [],"Single" },[])
  864. | TAbstract ({ a_path = [],"Single" },[]) ->
  865. path_s_import pos (["java";"lang"], "Float")
  866. | TDynamic _ -> "?"
  867. | TInst (cl, params) -> t_s pos (TInst(cl, change_param_type (TClassDecl cl) params))
  868. | TType (cl, params) -> t_s pos (TType(cl, change_param_type (TTypeDecl cl) params))
  869. | TEnum (e, params) -> t_s pos (TEnum(e, change_param_type (TEnumDecl e) params))
  870. | _ -> t_s pos t
  871. and path_param_s pos md path params =
  872. match params with
  873. | [] -> path_s_import pos path
  874. | _ when has_tdynamic (change_param_type md params) -> path_s_import pos path
  875. | _ -> sprintf "%s<%s>" (path_s_import pos path) (String.concat ", " (List.map (fun t -> param_t_s pos t) (change_param_type md params)))
  876. in
  877. let rett_s pos t =
  878. match t with
  879. | TEnum ({e_path = ([], "Void")}, [])
  880. | TAbstract ({ a_path = ([], "Void") },[]) -> "void"
  881. | _ -> t_s pos t
  882. in
  883. let high_surrogate c = (c lsr 10) + 0xD7C0 in
  884. let low_surrogate c = (c land 0x3FF) lor 0xDC00 in
  885. let escape ichar b =
  886. match ichar with
  887. | 92 (* \ *) -> Buffer.add_string b "\\\\"
  888. | 39 (* ' *) -> Buffer.add_string b "\\\'"
  889. | 34 -> Buffer.add_string b "\\\""
  890. | 13 (* \r *) -> Buffer.add_string b "\\r"
  891. | 10 (* \n *) -> Buffer.add_string b "\\n"
  892. | 9 (* \t *) -> Buffer.add_string b "\\t"
  893. | c when c < 32 || (c >= 127 && c <= 0xFFFF) -> Buffer.add_string b (Printf.sprintf "\\u%.4x" c)
  894. | c when c > 0xFFFF -> Buffer.add_string b (Printf.sprintf "\\u%.4x\\u%.4x" (high_surrogate c) (low_surrogate c))
  895. | c -> Buffer.add_char b (Char.chr c)
  896. in
  897. let escape s =
  898. let b = Buffer.create 0 in
  899. (try
  900. UTF8.validate s;
  901. UTF8.iter (fun c -> escape (UChar.code c) b) s
  902. with
  903. UTF8.Malformed_code ->
  904. String.iter (fun c -> escape (Char.code c) b) s
  905. );
  906. Buffer.contents b
  907. in
  908. let has_semicolon e =
  909. match e.eexpr with
  910. | TLocal { v_name = "__fallback__" }
  911. | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt _) } ] ) -> false
  912. | TBlock _ | TFor _ | TSwitch _ | TPatMatch _ | TTry _ | TIf _ -> false
  913. | TWhile (_,_,flag) when flag = Ast.NormalWhile -> false
  914. | _ -> true
  915. in
  916. let in_value = ref false in
  917. let rec md_s pos md =
  918. let md = follow_module (gen.gfollow#run_f) md in
  919. match md with
  920. | TClassDecl (cl) ->
  921. t_s pos (TInst(cl,[]))
  922. | TEnumDecl (e) ->
  923. t_s pos (TEnum(e,[]))
  924. | TTypeDecl t ->
  925. t_s pos (TType(t, []))
  926. | TAbstractDecl a ->
  927. t_s pos (TAbstract(a, []))
  928. in
  929. (*
  930. it seems that Java doesn't like when you create a new array with the type parameter defined
  931. so we'll just ignore all type parameters, and hope for the best!
  932. *)
  933. let rec transform_nativearray_t t = match real_type t with
  934. | TInst( ({ cl_path = (["java"], "NativeArray") } as narr), [t]) ->
  935. TInst(narr, [transform_nativearray_t t])
  936. | TInst(cl, params) -> TInst(cl, List.map (fun _ -> t_dynamic) params)
  937. | TEnum(e, params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
  938. | TType(t, params) -> TType(t, List.map (fun _ -> t_dynamic) params)
  939. | _ -> t
  940. in
  941. let expr_s w e =
  942. in_value := false;
  943. let rec expr_s w e =
  944. let was_in_value = !in_value in
  945. in_value := true;
  946. match e.eexpr with
  947. | TConst c ->
  948. (match c with
  949. | TInt i32 ->
  950. print w "%ld" i32;
  951. (match real_type e.etype with
  952. | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) -> write w "L";
  953. | _ -> ()
  954. )
  955. | TFloat s ->
  956. write w s;
  957. (* fix for Int notation, which only fit in a Float *)
  958. (if not (String.contains s '.' || String.contains s 'e' || String.contains s 'E') then write w ".0");
  959. (match real_type e.etype with
  960. | TType( { t_path = ([], "Single") }, [] ) -> write w "f"
  961. | _ -> ()
  962. )
  963. | TString s -> print w "\"%s\"" (escape s)
  964. | TBool b -> write w (if b then "true" else "false")
  965. | TNull ->
  966. (match real_type e.etype with
  967. | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] )
  968. | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> write w "0L"
  969. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  970. | TInst({ cl_path = ([], "Int") },[])
  971. | TAbstract ({ a_path = ([], "Int") },[]) -> expr_s w ({ e with eexpr = TConst(TInt Int32.zero) })
  972. | TInst({ cl_path = ([], "Float") },[])
  973. | TAbstract ({ a_path = ([], "Float") },[]) -> expr_s w ({ e with eexpr = TConst(TFloat "0.0") })
  974. | TEnum({ e_path = ([], "Bool") }, [])
  975. | TAbstract ({ a_path = ([], "Bool") },[]) -> write w "false"
  976. | TAbstract _ when like_int e.etype ->
  977. expr_s w { e with eexpr = TConst(TInt Int32.zero) }
  978. | TAbstract _ when like_float e.etype ->
  979. expr_s w { e with eexpr = TConst(TFloat "0.0") }
  980. | _ -> write w "null")
  981. | TThis -> write w "this"
  982. | TSuper -> write w "super")
  983. | TLocal { v_name = "__fallback__" } -> ()
  984. | TLocal { v_name = "__sbreak__" } -> write w "break"
  985. | TLocal { v_name = "__undefined__" } ->
  986. write w (t_s e.epos (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_types)));
  987. write w ".undefined";
  988. | TLocal var ->
  989. write_id w var.v_name
  990. | TField(_, FEnum(en,ef)) ->
  991. let s = ef.ef_name in
  992. print w "%s." (path_s_import e.epos en.e_path); write_field w s
  993. | TArray (e1, e2) ->
  994. expr_s w e1; write w "["; expr_s w e2; write w "]"
  995. | TBinop ((Ast.OpAssign as op), e1, e2)
  996. | TBinop ((Ast.OpAssignOp _ as op), e1, e2) ->
  997. expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2
  998. | TBinop (op, e1, e2) ->
  999. write w "( ";
  1000. expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2;
  1001. write w " )"
  1002. | TField (e, FStatic(_, cf)) when Meta.has Meta.Native cf.cf_meta ->
  1003. let rec loop meta = match meta with
  1004. | (Meta.Native, [EConst (String s), _],_) :: _ ->
  1005. expr_s w e; write w "."; write_field w s
  1006. | _ :: tl -> loop tl
  1007. | [] -> expr_s w e; write w "."; write_field w (cf.cf_name)
  1008. in
  1009. loop cf.cf_meta
  1010. | TField (e, s) ->
  1011. expr_s w e; write w "."; write_field w (field_name s)
  1012. | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int32") }) ->
  1013. write w (path_s_import e.epos (["haxe"], "Int32"))
  1014. | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int64") }) ->
  1015. write w (path_s_import e.epos (["haxe"], "Int64"))
  1016. | TTypeExpr mt -> write w (md_s e.epos mt)
  1017. | TParenthesis e ->
  1018. write w "("; expr_s w e; write w ")"
  1019. | TMeta (_,e) ->
  1020. expr_s w e
  1021. | TArrayDecl el when t_has_type_param_shallow false e.etype ->
  1022. print w "( (%s) (new java.lang.Object[] " (t_s e.epos e.etype);
  1023. write w "{";
  1024. ignore (List.fold_left (fun acc e ->
  1025. (if acc <> 0 then write w ", ");
  1026. expr_s w e;
  1027. acc + 1
  1028. ) 0 el);
  1029. write w "}) )"
  1030. | TArrayDecl el ->
  1031. print w "new %s" (param_t_s e.epos (transform_nativearray_t e.etype));
  1032. let is_double = match follow e.etype with
  1033. | TInst(_,[ t ]) -> if like_float t && not (like_int t) then Some t else None
  1034. | _ -> None
  1035. in
  1036. write w "{";
  1037. ignore (List.fold_left (fun acc e ->
  1038. (if acc <> 0 then write w ", ");
  1039. (* this is a hack so we are able to convert ints to boxed Double / Float when needed *)
  1040. let e = if is_some is_double then mk_cast (get is_double) e else e in
  1041. expr_s w e;
  1042. acc + 1
  1043. ) 0 el);
  1044. write w "}"
  1045. | TCall( ( { eexpr = TField(_, FStatic({ cl_path = ([], "String") }, { cf_name = "fromCharCode" })) } ), [cc] ) ->
  1046. write w "Character.toString((char) ";
  1047. expr_s w cc;
  1048. write w ")"
  1049. | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
  1050. write w "( ";
  1051. expr_s w expr;
  1052. write w " instanceof ";
  1053. write w (md_s e.epos md);
  1054. write w " )"
  1055. | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) ->
  1056. write w s
  1057. | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) ->
  1058. write w "synchronized(";
  1059. expr_s w eobj;
  1060. write w ")";
  1061. (match eblock.eexpr with
  1062. | TBlock(_ :: _) ->
  1063. expr_s w eblock
  1064. | _ ->
  1065. begin_block w;
  1066. expr_s w eblock;
  1067. if has_semicolon eblock then write w ";";
  1068. end_block w;
  1069. )
  1070. | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
  1071. print w "break label%ld" v
  1072. | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
  1073. print w "label%ld:" v
  1074. | TCall ({ eexpr = TLocal( { v_name = "__typeof__" } ) }, [ { eexpr = TTypeExpr md } as expr ] ) ->
  1075. expr_s w expr;
  1076. write w ".class"
  1077. | TCall (e, el) ->
  1078. let rec extract_tparams params el =
  1079. match el with
  1080. | ({ eexpr = TLocal({ v_name = "$type_param" }) } as tp) :: tl ->
  1081. extract_tparams (tp.etype :: params) tl
  1082. | _ -> (params, el)
  1083. in
  1084. let params, el = extract_tparams [] el in
  1085. expr_s w e;
  1086. (*(match params with
  1087. | [] -> ()
  1088. | params ->
  1089. let md = match e.eexpr with
  1090. | TField(ef, _) -> t_to_md (run_follow gen ef.etype)
  1091. | _ -> assert false
  1092. in
  1093. write w "<";
  1094. ignore (List.fold_left (fun acc t ->
  1095. (if acc <> 0 then write w ", ");
  1096. write w (param_t_s (change_param_type md t));
  1097. acc + 1
  1098. ) 0 params);
  1099. write w ">"
  1100. );*)
  1101. write w "(";
  1102. ignore (List.fold_left (fun acc e ->
  1103. (if acc <> 0 then write w ", ");
  1104. expr_s w e;
  1105. acc + 1
  1106. ) 0 el);
  1107. write w ")"
  1108. | TNew (({ cl_path = (["java"], "NativeArray") } as cl), params, [ size ]) ->
  1109. let rec check_t_s t times =
  1110. match real_type t with
  1111. | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
  1112. (check_t_s param (times+1))
  1113. | _ ->
  1114. print w "new %s[" (t_s e.epos (transform_nativearray_t t));
  1115. expr_s w size;
  1116. print w "]";
  1117. let rec loop i =
  1118. if i <= 0 then () else (write w "[]"; loop (i-1))
  1119. in
  1120. loop (times - 1)
  1121. in
  1122. check_t_s (TInst(cl, params)) 0
  1123. | TNew ({ cl_path = ([], "String") } as cl, [], el) ->
  1124. write w "new ";
  1125. write w (t_s e.epos (TInst(cl, [])));
  1126. write w "(";
  1127. ignore (List.fold_left (fun acc e ->
  1128. (if acc <> 0 then write w ", ");
  1129. expr_s w e;
  1130. acc + 1
  1131. ) 0 el);
  1132. write w ")"
  1133. | TNew ({ cl_kind = KTypeParameter _ } as cl, params, el) ->
  1134. print w "null /* This code should never be reached. It was produced by the use of @:generic on a new type parameter instance: %s */" (path_param_s e.epos (TClassDecl cl) cl.cl_path params)
  1135. | TNew (cl, params, el) ->
  1136. write w "new ";
  1137. write w (path_param_s e.epos (TClassDecl cl) cl.cl_path params);
  1138. write w "(";
  1139. ignore (List.fold_left (fun acc e ->
  1140. (if acc <> 0 then write w ", ");
  1141. expr_s w e;
  1142. acc + 1
  1143. ) 0 el);
  1144. write w ")"
  1145. | TUnop ((Ast.Increment as op), flag, e)
  1146. | TUnop ((Ast.Decrement as op), flag, e) ->
  1147. (match flag with
  1148. | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " " ); expr_s w e
  1149. | Ast.Postfix -> expr_s w e; write w (Ast.s_unop op))
  1150. | TUnop (op, flag, e) ->
  1151. (match flag with
  1152. | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " (" ); expr_s w e; write w ") "
  1153. | Ast.Postfix -> write w "("; expr_s w e; write w (") " ^ Ast.s_unop op))
  1154. | TVar (var, eopt) ->
  1155. print w "%s " (t_s e.epos var.v_type);
  1156. write_id w var.v_name;
  1157. (match eopt with
  1158. | None ->
  1159. write w " = ";
  1160. expr_s w (null var.v_type e.epos)
  1161. | Some e ->
  1162. write w " = ";
  1163. expr_s w e
  1164. )
  1165. | TBlock [e] when was_in_value ->
  1166. expr_s w e
  1167. | TBlock el ->
  1168. begin_block w;
  1169. (*let last_line = ref (-1) in
  1170. let line_directive p =
  1171. let cur_line = Lexer.get_error_line p in
  1172. let is_relative_path = (String.sub p.pfile 0 1) = "." in
  1173. let file = if is_relative_path then "../" ^ p.pfile else p.pfile in
  1174. if cur_line <> ((!last_line)+1) then begin print w "//#line %d \"%s\"" cur_line (Ast.s_escape file); newline w end;
  1175. last_line := cur_line in*)
  1176. List.iter (fun e ->
  1177. (*line_directive e.epos;*)
  1178. in_value := false;
  1179. (match e.eexpr with
  1180. | TConst _ -> ()
  1181. | _ ->
  1182. expr_s w e;
  1183. (if has_semicolon e then write w ";");
  1184. newline w);
  1185. ) el;
  1186. end_block w
  1187. | TIf (econd, e1, Some(eelse)) when was_in_value ->
  1188. write w "( ";
  1189. expr_s w (mk_paren econd);
  1190. write w " ? ";
  1191. expr_s w (mk_paren e1);
  1192. write w " : ";
  1193. expr_s w (mk_paren eelse);
  1194. write w " )";
  1195. | TIf (econd, e1, eelse) ->
  1196. write w "if ";
  1197. expr_s w (mk_paren econd);
  1198. write w " ";
  1199. in_value := false;
  1200. expr_s w (mk_block e1);
  1201. (match eelse with
  1202. | None -> ()
  1203. | Some e ->
  1204. write w " else ";
  1205. in_value := false;
  1206. expr_s w (mk_block e)
  1207. )
  1208. | TWhile (econd, eblock, flag) ->
  1209. (match flag with
  1210. | Ast.NormalWhile ->
  1211. write w "while ";
  1212. expr_s w (mk_paren econd);
  1213. write w "";
  1214. in_value := false;
  1215. expr_s w (mk_block eblock)
  1216. | Ast.DoWhile ->
  1217. write w "do ";
  1218. in_value := false;
  1219. expr_s w (mk_block eblock);
  1220. write w "while ";
  1221. in_value := true;
  1222. expr_s w (mk_paren econd);
  1223. )
  1224. | TSwitch (econd, ele_l, default) ->
  1225. write w "switch ";
  1226. expr_s w (mk_paren econd);
  1227. begin_block w;
  1228. List.iter (fun (el, e) ->
  1229. List.iter (fun e ->
  1230. write w "case ";
  1231. in_value := true;
  1232. expr_s w e;
  1233. write w ":";
  1234. ) el;
  1235. newline w;
  1236. in_value := false;
  1237. expr_s w (mk_block e);
  1238. newline w;
  1239. newline w
  1240. ) ele_l;
  1241. if is_some default then begin
  1242. write w "default:";
  1243. newline w;
  1244. in_value := false;
  1245. expr_s w (get default);
  1246. newline w;
  1247. end;
  1248. end_block w
  1249. | TTry (tryexpr, ve_l) ->
  1250. write w "try ";
  1251. in_value := false;
  1252. expr_s w (mk_block tryexpr);
  1253. let pos = e.epos in
  1254. List.iter (fun (var, e) ->
  1255. print w "catch (%s %s)" (t_s pos var.v_type) (var.v_name);
  1256. in_value := false;
  1257. expr_s w (mk_block e);
  1258. newline w
  1259. ) ve_l
  1260. | TReturn eopt ->
  1261. write w "return ";
  1262. if is_some eopt then expr_s w (get eopt)
  1263. | TBreak -> write w "break"
  1264. | TContinue -> write w "continue"
  1265. | TThrow e ->
  1266. write w "throw ";
  1267. expr_s w e
  1268. | TCast (e1,md_t) ->
  1269. ((*match gen.gfollow#run_f e.etype with
  1270. | TType({ t_path = ([], "UInt") }, []) ->
  1271. write w "( unchecked ((uint) ";
  1272. expr_s w e1;
  1273. write w ") )"
  1274. | _ ->*)
  1275. (* FIXME I'm ignoring module type *)
  1276. print w "((%s) (" (t_s e.epos e.etype);
  1277. expr_s w e1;
  1278. write w ") )"
  1279. )
  1280. | TFor (_,_,content) ->
  1281. write w "[ for not supported ";
  1282. expr_s w content;
  1283. write w " ]";
  1284. if !strict_mode then assert false
  1285. | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
  1286. | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
  1287. | TPatMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false
  1288. | TEnumParameter _ -> write w "[ enum parameter not supported ]"; if !strict_mode then assert false
  1289. in
  1290. expr_s w e
  1291. in
  1292. let get_string_params cl_types =
  1293. match cl_types with
  1294. | [] ->
  1295. ("","")
  1296. | _ ->
  1297. 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
  1298. let params_extends = List.fold_left (fun acc (name, t) ->
  1299. match run_follow gen t with
  1300. | TInst (cl, p) ->
  1301. (match cl.cl_implements with
  1302. | [] -> acc
  1303. | _ -> acc) (* TODO
  1304. | _ -> (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 ) *)
  1305. | _ -> trace (t_s Ast.null_pos 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 *)
  1306. ) [] cl_types in
  1307. (params, String.concat " " params_extends)
  1308. in
  1309. let rec gen_class_field w ?(is_overload=false) is_static cl is_final cf =
  1310. let is_interface = cl.cl_interface in
  1311. let name, is_new, is_explicit_iface = match cf.cf_name with
  1312. | "new" -> snd cl.cl_path, true, false
  1313. | name when String.contains name '.' ->
  1314. let fn_name, path = parse_explicit_iface name in
  1315. (path_s path) ^ "." ^ fn_name, false, true
  1316. | name -> name, false, false
  1317. in
  1318. (match cf.cf_kind with
  1319. | Var _
  1320. | Method (MethDynamic) when not (Type.is_extern_field cf) ->
  1321. (if is_overload || List.exists (fun cf -> cf.cf_expr <> None) cf.cf_overloads then
  1322. gen.gcon.error "Only normal (non-dynamic) methods can be overloaded" cf.cf_pos);
  1323. if not is_interface then begin
  1324. let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in
  1325. print w "%s %s%s %s %s" access (if is_static then "static " else "") (String.concat " " modifiers) (t_s cf.cf_pos (run_follow gen cf.cf_type)) (change_field name);
  1326. (match cf.cf_expr with
  1327. | Some e ->
  1328. write w " = ";
  1329. expr_s w e;
  1330. write w ";"
  1331. | None -> write w ";"
  1332. )
  1333. end (* TODO see how (get,set) variable handle when they are interfaces *)
  1334. | Method _ when Type.is_extern_field cf || (match cl.cl_kind, cf.cf_expr with | KAbstractImpl _, None -> true | _ -> false) ->
  1335. List.iter (fun cf -> if cl.cl_interface || cf.cf_expr <> None then
  1336. gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
  1337. ) cf.cf_overloads
  1338. | Var _ | Method MethDynamic -> ()
  1339. | Method mkind ->
  1340. List.iter (fun cf ->
  1341. if cl.cl_interface || cf.cf_expr <> None then
  1342. gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
  1343. ) cf.cf_overloads;
  1344. let is_virtual = is_new || (not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false) in
  1345. let is_override = match cf.cf_name with
  1346. | "equals" when not is_static ->
  1347. (match cf.cf_type with
  1348. | TFun([_,_,t], ret) ->
  1349. (match (real_type t, real_type ret) with
  1350. | TDynamic _, TEnum( { e_path = ([], "Bool") }, [])
  1351. | TDynamic _, TAbstract ({ a_path = ([], "Bool") },[])
  1352. | TAnon _, TEnum( { e_path = ([], "Bool") }, [])
  1353. | TAnon _, TAbstract ({ a_path = ([], "Bool") },[]) -> true
  1354. | _ -> List.memq cf cl.cl_overrides
  1355. )
  1356. | _ -> List.memq cf cl.cl_overrides)
  1357. | "toString" when not is_static ->
  1358. (match cf.cf_type with
  1359. | TFun([], ret) ->
  1360. (match real_type ret with
  1361. | TInst( { cl_path = ([], "String") }, []) -> true
  1362. | _ -> gen.gcon.error "A toString() function should return a String!" cf.cf_pos; false
  1363. )
  1364. | _ -> List.memq cf cl.cl_overrides
  1365. )
  1366. | "hashCode" when not is_static ->
  1367. (match cf.cf_type with
  1368. | TFun([], ret) ->
  1369. (match real_type ret with
  1370. | TInst( { cl_path = ([], "Int") }, [])
  1371. | TAbstract ({ a_path = ([], "Int") },[]) ->
  1372. true
  1373. | _ -> gen.gcon.error "A hashCode() function should return an Int!" cf.cf_pos; false
  1374. )
  1375. | _ -> List.memq cf cl.cl_overrides
  1376. )
  1377. | _ -> List.memq cf cl.cl_overrides
  1378. in
  1379. let visibility = if is_interface then "" else "public" in
  1380. let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in
  1381. let visibility, is_virtual = if is_explicit_iface then "",false else visibility, is_virtual in
  1382. 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
  1383. let cf_type = if is_override && not is_overload && not (Meta.has Meta.Overload cf.cf_meta) 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
  1384. let params = List.map snd cl.cl_types in
  1385. let ret_type, args = match follow cf_type, follow cf.cf_type with
  1386. | TFun (strbtl, t), TFun(rargs, _) ->
  1387. (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)
  1388. | _ -> assert false
  1389. in
  1390. (if is_override && not is_interface then write w "@Override ");
  1391. (* public static void funcName *)
  1392. let params, _ = get_string_params cf.cf_params in
  1393. print w "%s %s%s %s %s %s" (visibility) v_n (String.concat " " modifiers) params (if is_new then "" else rett_s cf.cf_pos (run_follow gen ret_type)) (change_field name);
  1394. (* <T>(string arg1, object arg2) with T : object *)
  1395. (match cf.cf_expr with
  1396. | Some { eexpr = TFunction tf } ->
  1397. print w "(%s)" (String.concat ", " (List.map2 (fun (var,_) (_,_,t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id var.v_name)) tf.tf_args args))
  1398. | _ ->
  1399. print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id name)) args))
  1400. );
  1401. if is_interface || List.mem "native" modifiers then
  1402. write w ";"
  1403. else begin
  1404. let rec loop meta =
  1405. match meta with
  1406. | [] ->
  1407. let expr = match cf.cf_expr with
  1408. | None -> mk (TBlock([])) t_dynamic Ast.null_pos
  1409. | Some s ->
  1410. match s.eexpr with
  1411. | TFunction tf ->
  1412. mk_block (tf.tf_expr)
  1413. | _ -> assert false (* FIXME *)
  1414. in
  1415. (if is_new then begin
  1416. (*let rec get_super_call el =
  1417. match el with
  1418. | ( { eexpr = TCall( { eexpr = TConst(TSuper) }, _) } as call) :: rest ->
  1419. Some call, rest
  1420. | ( { eexpr = TBlock(bl) } as block ) :: rest ->
  1421. let ret, mapped = get_super_call bl in
  1422. ret, ( { block with eexpr = TBlock(mapped) } :: rest )
  1423. | _ ->
  1424. None, el
  1425. in*)
  1426. expr_s w expr
  1427. end else begin
  1428. expr_s w expr;
  1429. end)
  1430. | (Meta.Throws, [Ast.EConst (Ast.String t), _], _) :: tl ->
  1431. print w " throws %s" t;
  1432. loop tl
  1433. | (Meta.FunctionCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
  1434. begin_block w;
  1435. write w contents;
  1436. end_block w
  1437. | _ :: tl -> loop tl
  1438. in
  1439. loop cf.cf_meta
  1440. end);
  1441. newline w;
  1442. newline w
  1443. in
  1444. let gen_class w cl =
  1445. let should_close = match change_ns (fst cl.cl_path) with
  1446. | [] -> false
  1447. | ns ->
  1448. print w "package %s;" (String.concat "." (change_ns ns));
  1449. newline w;
  1450. false
  1451. in
  1452. let rec loop_meta meta acc =
  1453. match meta with
  1454. | (Meta.SuppressWarnings, [Ast.EConst (Ast.String w),_],_) :: meta -> loop_meta meta (w :: acc)
  1455. | _ :: meta -> loop_meta meta acc
  1456. | _ -> acc
  1457. in
  1458. let suppress_warnings = loop_meta cl.cl_meta [ "rawtypes"; "unchecked" ] in
  1459. write w "import haxe.root.*;";
  1460. newline w;
  1461. let w_header = w in
  1462. let w = new_source_writer () in
  1463. clear_scope();
  1464. (* add all haxe.root.* to imports *)
  1465. List.iter (function
  1466. | TClassDecl { cl_path = ([],c) } ->
  1467. imports := ([],c) :: !imports
  1468. | TEnumDecl { e_path = ([],c) } ->
  1469. imports := ([],c) :: !imports
  1470. | TAbstractDecl { a_path = ([],c) } ->
  1471. imports := ([],c) :: !imports
  1472. | _ -> ()
  1473. ) gen.gcon.types;
  1474. newline w;
  1475. write w "@SuppressWarnings(value={";
  1476. let first = ref true in
  1477. List.iter (fun s ->
  1478. (if !first then first := false else write w ", ");
  1479. print w "\"%s\"" (escape s)
  1480. ) suppress_warnings;
  1481. write w "})";
  1482. newline w;
  1483. let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
  1484. let is_final = Meta.has Meta.Final cl.cl_meta in
  1485. print w "%s %s %s %s" access (String.concat " " modifiers) clt (change_clname (snd cl.cl_path));
  1486. (* type parameters *)
  1487. let params, _ = get_string_params cl.cl_types in
  1488. let cl_p_to_string (c,p) =
  1489. let p = List.map (fun t -> match follow t with
  1490. | TMono _ | TDynamic _ -> t_empty
  1491. | _ -> t) p
  1492. in
  1493. path_param_s cl.cl_pos (TClassDecl c) c.cl_path p
  1494. in
  1495. print w "%s" params;
  1496. (if is_some cl.cl_super then print w " extends %s" (cl_p_to_string (get cl.cl_super)));
  1497. (match cl.cl_implements with
  1498. | [] -> ()
  1499. | _ -> print w " %s %s" (if cl.cl_interface then "extends" else "implements") (String.concat ", " (List.map cl_p_to_string cl.cl_implements))
  1500. );
  1501. (* class head ok: *)
  1502. (* public class Test<A> : X, Y, Z where A : Y *)
  1503. begin_block w;
  1504. (* our constructor is expected to be a normal "new" function *
  1505. if !strict_mode && is_some cl.cl_constructor then assert false;*)
  1506. let rec loop cl =
  1507. List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_fields;
  1508. List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_statics;
  1509. match cl.cl_super with
  1510. | Some(c,_) -> loop c
  1511. | None -> ()
  1512. in
  1513. loop cl;
  1514. let rec loop meta =
  1515. match meta with
  1516. | [] -> ()
  1517. | (Meta.ClassCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
  1518. write w contents
  1519. | _ :: tl -> loop tl
  1520. in
  1521. loop cl.cl_meta;
  1522. (match gen.gcon.main_class with
  1523. | Some path when path = cl.cl_path ->
  1524. write w "public static void main(String[] args)";
  1525. begin_block w;
  1526. (try
  1527. let t = Hashtbl.find gen.gtypes ([], "Sys") in
  1528. match t with
  1529. | TClassDecl(cl) when PMap.mem "_args" cl.cl_statics ->
  1530. write w "Sys._args = args;"; newline w
  1531. | _ -> ()
  1532. with | Not_found -> ()
  1533. );
  1534. write w "main();";
  1535. end_block w
  1536. | _ -> ()
  1537. );
  1538. (match cl.cl_init with
  1539. | None -> ()
  1540. | Some init ->
  1541. write w "static ";
  1542. expr_s w (mk_block init));
  1543. (if is_some cl.cl_constructor then gen_class_field w false cl is_final (get cl.cl_constructor));
  1544. (if not cl.cl_interface then
  1545. List.iter (gen_class_field w true cl is_final) cl.cl_ordered_statics);
  1546. List.iter (gen_class_field w false cl is_final) cl.cl_ordered_fields;
  1547. end_block w;
  1548. if should_close then end_block w;
  1549. (* add imports *)
  1550. List.iter (function
  1551. | ["haxe";"root"], _ | [], _ -> ()
  1552. | path ->
  1553. write w_header "import ";
  1554. write w_header (path_s path);
  1555. write w_header ";\n"
  1556. ) !imports;
  1557. add_writer w w_header
  1558. in
  1559. let gen_enum w e =
  1560. let should_close = match change_ns (fst e.e_path) with
  1561. | [] -> false
  1562. | ns ->
  1563. print w "package %s;" (String.concat "." (change_ns ns));
  1564. newline w;
  1565. false
  1566. in
  1567. print w "public enum %s" (change_clname (snd e.e_path));
  1568. begin_block w;
  1569. write w (String.concat ", " (List.map (change_id) e.e_names));
  1570. end_block w;
  1571. if should_close then end_block w
  1572. in
  1573. let module_type_gen w md_tp =
  1574. match md_tp with
  1575. | TClassDecl cl ->
  1576. if not cl.cl_extern then begin
  1577. gen_class w cl;
  1578. newline w;
  1579. newline w
  1580. end;
  1581. (not cl.cl_extern)
  1582. | TEnumDecl e ->
  1583. if not e.e_extern then begin
  1584. gen_enum w e;
  1585. newline w;
  1586. newline w
  1587. end;
  1588. (not e.e_extern)
  1589. | TTypeDecl e ->
  1590. false
  1591. | TAbstractDecl a ->
  1592. false
  1593. in
  1594. let module_gen w md =
  1595. module_type_gen w md
  1596. in
  1597. (* generate source code *)
  1598. init_ctx gen;
  1599. Hashtbl.add gen.gspecial_vars "__label__" true;
  1600. Hashtbl.add gen.gspecial_vars "__goto__" true;
  1601. Hashtbl.add gen.gspecial_vars "__is__" true;
  1602. Hashtbl.add gen.gspecial_vars "__typeof__" true;
  1603. Hashtbl.add gen.gspecial_vars "__java__" true;
  1604. Hashtbl.add gen.gspecial_vars "__lock__" true;
  1605. gen.greal_type <- real_type;
  1606. gen.greal_type_param <- change_param_type;
  1607. SetHXGen.run_filter gen SetHXGen.default_hxgen_func;
  1608. (* before running the filters, follow all possible types *)
  1609. (* this is needed so our module transformations don't break some core features *)
  1610. (* like multitype selection *)
  1611. let run_follow_gen = run_follow gen in
  1612. let rec type_map e = Type.map_expr_type (fun e->type_map e) (run_follow_gen) (fun tvar-> tvar.v_type <- (run_follow_gen tvar.v_type); tvar) e in
  1613. let super_map (cl,tl) = (cl, List.map run_follow_gen tl) in
  1614. List.iter (function
  1615. | TClassDecl cl ->
  1616. let all_fields = (Option.map_default (fun cf -> [cf]) [] cl.cl_constructor) @ cl.cl_ordered_fields @ cl.cl_ordered_statics in
  1617. List.iter (fun cf ->
  1618. cf.cf_type <- run_follow_gen cf.cf_type;
  1619. cf.cf_expr <- Option.map type_map cf.cf_expr
  1620. ) all_fields;
  1621. cl.cl_dynamic <- Option.map run_follow_gen cl.cl_dynamic;
  1622. cl.cl_array_access <- Option.map run_follow_gen cl.cl_array_access;
  1623. cl.cl_init <- Option.map type_map cl.cl_init;
  1624. cl.cl_super <- Option.map super_map cl.cl_super;
  1625. cl.cl_implements <- List.map super_map cl.cl_implements
  1626. | _ -> ()
  1627. ) gen.gcon.types;
  1628. let closure_t = ClosuresToClass.DoubleAndDynamicClosureImpl.get_ctx gen 6 in
  1629. (*let closure_t = ClosuresToClass.create gen 10 float_cl
  1630. (fun l -> l)
  1631. (fun l -> l)
  1632. (fun args -> args)
  1633. (fun args -> [])
  1634. in
  1635. ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (fun e _ _ -> e));
  1636. StubClosureImpl.configure gen (StubClosureImpl.default_implementation gen float_cl 10 (fun e _ _ -> e));*)
  1637. FixOverrides.configure gen;
  1638. Normalize.configure gen ~metas:(Hashtbl.create 0);
  1639. AbstractImplementationFix.configure gen;
  1640. IteratorsInterface.configure gen (fun e -> e);
  1641. ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) ));
  1642. EnumToClass.configure gen (None) false true (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) false false;
  1643. InterfaceVarsDeleteModf.configure gen;
  1644. let dynamic_object = (get_cl (get_type gen (["haxe";"lang"],"DynamicObject")) ) in
  1645. let object_iface = get_cl (get_type gen (["haxe";"lang"],"IHxObject")) in
  1646. (*fixme: THIS IS A HACK. take this off *)
  1647. let empty_e = match (get_type gen (["haxe";"lang"], "EmptyObject")) with | TEnumDecl e -> e | _ -> assert false in
  1648. (*OverloadingCtor.set_new_create_empty gen ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;});*)
  1649. let empty_expr = { eexpr = (TTypeExpr (TEnumDecl empty_e)); etype = (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics empty_e) }); epos = null_pos } in
  1650. let empty_ef =
  1651. try
  1652. PMap.find "EMPTY" empty_e.e_constrs
  1653. with Not_found -> gen.gcon.error "Required enum field EMPTY was not found" empty_e.e_pos; assert false
  1654. in
  1655. OverloadingConstructor.configure ~empty_ctor_type:(TEnum(empty_e, [])) ~empty_ctor_expr:({ eexpr=TField(empty_expr, FEnum(empty_e, empty_ef)); etype=TEnum(empty_e,[]); epos=null_pos; }) ~supports_ctor_inheritance:false gen;
  1656. let rcf_static_find = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "findHash" Ast.null_pos [] in
  1657. (*let rcf_static_lookup = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "lookupHash" Ast.null_pos [] in*)
  1658. let can_be_float t = like_float (real_type t) in
  1659. let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe =
  1660. let is_float = can_be_float (if is_none may_set then main_expr.etype else (get may_set).etype) in
  1661. let fn_name = if is_some may_set then "setField" else "getField" in
  1662. let fn_name = if is_float then fn_name ^ "_f" else fn_name in
  1663. let pos = field_expr.epos in
  1664. let is_unsafe = { eexpr = TConst(TBool is_unsafe); etype = basic.tbool; epos = pos } in
  1665. let should_cast = match main_expr.etype with | TInst({ cl_path = ([], "Float") }, []) -> false | _ -> true in
  1666. let infer = mk_static_field_access_infer runtime_cl fn_name field_expr.epos [] in
  1667. let first_args =
  1668. [ field_expr; { eexpr = TConst(TString field); etype = basic.tstring; epos = pos } ]
  1669. @ if is_some may_hash then [ { eexpr = TConst(TInt (get may_hash)); etype = basic.tint; epos = pos } ] else []
  1670. in
  1671. let args = first_args @ match is_float, may_set with
  1672. | true, Some(set) ->
  1673. [ if should_cast then mk_cast basic.tfloat set else set ]
  1674. | false, Some(set) ->
  1675. [ set ]
  1676. | _ ->
  1677. [ is_unsafe ]
  1678. in
  1679. let call = { main_expr with eexpr = TCall(infer,args) } in
  1680. let call = if is_float && should_cast then mk_cast main_expr.etype call else call in
  1681. call
  1682. in
  1683. let rcf_on_call_field ecall field_expr field may_hash args =
  1684. let infer = mk_static_field_access_infer runtime_cl "callField" field_expr.epos [] in
  1685. let hash_arg = match may_hash with
  1686. | None -> []
  1687. | Some h -> [ { eexpr = TConst(TInt h); etype = basic.tint; epos = field_expr.epos } ]
  1688. in
  1689. let arr_call = if args <> [] then
  1690. { eexpr = TArrayDecl args; etype = basic.tarray t_dynamic; epos = ecall.epos }
  1691. else
  1692. null (basic.tarray t_dynamic) ecall.epos
  1693. in
  1694. let call_args =
  1695. [field_expr; { field_expr with eexpr = TConst(TString field); etype = basic.tstring } ]
  1696. @ hash_arg
  1697. @ [ arr_call ]
  1698. in
  1699. mk_cast ecall.etype { ecall with eexpr = TCall(infer, call_args); etype = t_dynamic }
  1700. in
  1701. let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface false rcf_on_getset_field rcf_on_call_field (fun hash hash_array ->
  1702. { hash with eexpr = TCall(rcf_static_find, [hash; hash_array]); etype=basic.tint }
  1703. ) (fun hash -> hash ) false in
  1704. ReflectionCFs.UniversalBaseClass.default_config gen (get_cl (get_type gen (["haxe";"lang"],"HxObject")) ) object_iface dynamic_object;
  1705. ReflectionCFs.configure_dynamic_field_access rcf_ctx false;
  1706. (* let closure_func = ReflectionCFs.implement_closure_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"],"Closure")) ) in *)
  1707. let closure_cl = get_cl (get_type gen (["haxe";"lang"],"Closure")) in
  1708. let closure_func = ReflectionCFs.get_closure_func rcf_ctx closure_cl in
  1709. ReflectionCFs.implement_varargs_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"], "VarArgsBase")) );
  1710. let slow_invoke = mk_static_field_access_infer (runtime_cl) "slowCallField" Ast.null_pos [] in
  1711. ReflectionCFs.configure rcf_ctx ~slow_invoke:(fun ethis efield eargs -> {
  1712. eexpr = TCall(slow_invoke, [ethis; efield; eargs]);
  1713. etype = t_dynamic;
  1714. epos = ethis.epos;
  1715. } ) object_iface;
  1716. let objdecl_fn = ReflectionCFs.implement_dynamic_object_ctor rcf_ctx dynamic_object in
  1717. ObjectDeclMap.configure gen (ObjectDeclMap.traverse gen objdecl_fn);
  1718. InitFunction.configure gen true;
  1719. TArrayTransform.configure gen (TArrayTransform.default_implementation gen (
  1720. fun e _ ->
  1721. match e.eexpr with
  1722. | TArray ({ eexpr = TLocal { v_extra = Some( _ :: _, _) } }, _) -> (* captured transformation *)
  1723. false
  1724. | TArray(e1, e2) ->
  1725. ( match run_follow gen (follow e1.etype) with
  1726. | TInst({ cl_path = (["java"], "NativeArray") }, _) -> false
  1727. | _ -> true )
  1728. | _ -> assert false
  1729. ) "__get" "__set" );
  1730. let field_is_dynamic t field =
  1731. match field_access_esp gen (gen.greal_type t) field with
  1732. | FClassField (cl,p,_,_,_,t,_) ->
  1733. is_dynamic (apply_params cl.cl_types p t)
  1734. | FEnumField _ -> false
  1735. | _ -> true
  1736. in
  1737. let is_type_param e = match follow e with
  1738. | TInst( { cl_kind = KTypeParameter _ },[]) -> true
  1739. | _ -> false
  1740. in
  1741. let is_dynamic_expr e = is_dynamic e.etype || match e.eexpr with
  1742. | TField(tf, f) -> field_is_dynamic tf.etype f
  1743. | _ -> false
  1744. in
  1745. let may_nullable t = match gen.gfollow#run_f t with
  1746. | TType({ t_path = ([], "Null") }, [t]) ->
  1747. (match follow t with
  1748. | TInst({ cl_path = ([], "String") }, [])
  1749. | TInst({ cl_path = ([], "Float") }, [])
  1750. | TAbstract ({ a_path = ([], "Float") },[])
  1751. | TInst({ cl_path = (["haxe"], "Int32")}, [] )
  1752. | TInst({ cl_path = (["haxe"], "Int64")}, [] )
  1753. | TInst({ cl_path = ([], "Int") }, [])
  1754. | TAbstract ({ a_path = ([], "Int") },[])
  1755. | TEnum({ e_path = ([], "Bool") }, [])
  1756. | TAbstract ({ a_path = ([], "Bool") },[]) -> Some t
  1757. | _ -> None )
  1758. | _ -> None
  1759. in
  1760. let is_double t = like_float t && not (like_int t) in
  1761. let is_int t = like_int t in
  1762. DynamicOperators.configure gen
  1763. (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with
  1764. | TBinop (Ast.OpEq, e1, e2)
  1765. | TBinop (Ast.OpAdd, e1, e2)
  1766. | TBinop (Ast.OpNotEq, e1, e2) -> is_dynamic e1.etype || is_dynamic e2.etype || is_type_param e1.etype || is_type_param e2.etype
  1767. | TBinop (Ast.OpLt, e1, e2)
  1768. | TBinop (Ast.OpLte, e1, e2)
  1769. | TBinop (Ast.OpGte, e1, e2)
  1770. | TBinop (Ast.OpGt, e1, e2) -> is_dynamic e.etype || is_dynamic_expr e1 || is_dynamic_expr e2 || is_string e1.etype || is_string e2.etype
  1771. | TBinop (_, e1, e2) -> is_dynamic e.etype || is_dynamic_expr e1 || is_dynamic_expr e2
  1772. | TUnop (_, _, e1) -> is_dynamic_expr e1
  1773. | _ -> false)
  1774. (fun e1 e2 ->
  1775. let is_null e = match e.eexpr with | TConst(TNull) | TLocal({ v_name = "__undefined__" }) -> true | _ -> false in
  1776. if is_null e1 || is_null e2 then
  1777. match e1.eexpr, e2.eexpr with
  1778. | TConst c1, TConst c2 ->
  1779. { e1 with eexpr = TConst(TBool (c1 = c2)); etype = basic.tbool }
  1780. | _ ->
  1781. { e1 with eexpr = TBinop(Ast.OpEq, e1, e2); etype = basic.tbool }
  1782. else begin
  1783. let is_ref = match follow e1.etype, follow e2.etype with
  1784. | TDynamic _, _
  1785. | _, TDynamic _
  1786. | TInst({ cl_path = ([], "Float") },[]), _
  1787. | TAbstract ({ a_path = ([], "Float") },[]) , _
  1788. | TInst( { cl_path = (["haxe"], "Int32") }, [] ), _
  1789. | TInst( { cl_path = (["haxe"], "Int64") }, [] ), _
  1790. | TInst({ cl_path = ([], "Int") },[]), _
  1791. | TAbstract ({ a_path = ([], "Int") },[]) , _
  1792. | TEnum({ e_path = ([], "Bool") },[]), _
  1793. | TAbstract ({ a_path = ([], "Bool") },[]) , _
  1794. | _, TInst({ cl_path = ([], "Float") },[])
  1795. | _, TAbstract ({ a_path = ([], "Float") },[])
  1796. | _, TInst({ cl_path = ([], "Int") },[])
  1797. | _, TAbstract ({ a_path = ([], "Int") },[])
  1798. | _, TInst( { cl_path = (["haxe"], "Int32") }, [] )
  1799. | _, TInst( { cl_path = (["haxe"], "Int64") }, [] )
  1800. | _, TEnum({ e_path = ([], "Bool") },[])
  1801. | _, TAbstract ({ a_path = ([], "Bool") },[])
  1802. | TInst( { cl_kind = KTypeParameter _ }, [] ), _
  1803. | _, TInst( { cl_kind = KTypeParameter _ }, [] ) -> false
  1804. | _, _ -> true
  1805. in
  1806. let static = mk_static_field_access_infer (runtime_cl) (if is_ref then "refEq" else "eq") e1.epos [] in
  1807. { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tbool; epos=e1.epos }
  1808. end
  1809. )
  1810. (fun e e1 e2 ->
  1811. match may_nullable e1.etype, may_nullable e2.etype with
  1812. | Some t1, Some t2 ->
  1813. let t1, t2 = if is_string t1 || is_string t2 then
  1814. basic.tstring, basic.tstring
  1815. else if is_double t1 || is_double t2 then
  1816. basic.tfloat, basic.tfloat
  1817. else if is_int t1 || is_int t2 then
  1818. basic.tint, basic.tint
  1819. else t1, t2 in
  1820. { eexpr = TBinop(Ast.OpAdd, mk_cast t1 e1, mk_cast t2 e2); etype = e.etype; epos = e1.epos }
  1821. | _ ->
  1822. let static = mk_static_field_access_infer (runtime_cl) "plus" e1.epos [] in
  1823. mk_cast e.etype { eexpr = TCall(static, [e1; e2]); etype = t_dynamic; epos=e1.epos })
  1824. (fun e1 e2 ->
  1825. if is_string e1.etype then begin
  1826. { e1 with eexpr = TCall(mk_field_access gen e1 "compareTo" e1.epos, [ e2 ]); etype = gen.gcon.basic.tint }
  1827. end else begin
  1828. let static = mk_static_field_access_infer (runtime_cl) "compare" e1.epos [] in
  1829. { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tint; epos=e1.epos }
  1830. end));
  1831. FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func);
  1832. let base_exception = get_cl (get_type gen (["java"; "lang"], "Throwable")) in
  1833. let base_exception_t = TInst(base_exception, []) in
  1834. let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in
  1835. let hx_exception_t = TInst(hx_exception, []) in
  1836. let rec is_exception t =
  1837. match follow t with
  1838. | TInst(cl,_) ->
  1839. if cl == base_exception then
  1840. true
  1841. else
  1842. (match cl.cl_super with | None -> false | Some (cl,arg) -> is_exception (TInst(cl,arg)))
  1843. | _ -> false
  1844. in
  1845. TryCatchWrapper.configure gen
  1846. (
  1847. TryCatchWrapper.traverse gen
  1848. (fun t -> not (is_exception (real_type t)))
  1849. (fun throwexpr expr ->
  1850. let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) expr.epos in
  1851. { throwexpr with eexpr = TThrow { expr with eexpr = TCall(wrap_static, [expr]); etype = hx_exception_t }; etype = gen.gcon.basic.tvoid }
  1852. )
  1853. (fun v_to_unwrap pos ->
  1854. let local = mk_cast hx_exception_t { eexpr = TLocal(v_to_unwrap); etype = v_to_unwrap.v_type; epos = pos } in
  1855. mk_field_access gen local "obj" pos
  1856. )
  1857. (fun rethrow ->
  1858. let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) rethrow.epos in
  1859. { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]) }; }
  1860. )
  1861. (base_exception_t)
  1862. (hx_exception_t)
  1863. (fun v e -> e)
  1864. );
  1865. let get_typeof e =
  1866. { e with eexpr = TCall( { eexpr = TLocal( alloc_var "__typeof__" t_dynamic ); etype = t_dynamic; epos = e.epos }, [e] ) }
  1867. in
  1868. ClassInstance.configure gen (ClassInstance.traverse gen (fun e mt -> get_typeof e));
  1869. (*let v = alloc_var "$type_param" t_dynamic in*)
  1870. TypeParams.configure gen (fun ecall efield params elist ->
  1871. { ecall with eexpr = TCall(efield, elist) }
  1872. );
  1873. CastDetect.configure gen (CastDetect.default_implementation gen ~native_string_cast:false (Some (TEnum(empty_e, []))) false);
  1874. (*FollowAll.configure gen;*)
  1875. SwitchToIf.configure gen (SwitchToIf.traverse gen (fun e ->
  1876. match e.eexpr with
  1877. | TSwitch(cond, cases, def) ->
  1878. (match gen.gfollow#run_f cond.etype with
  1879. | TInst( { cl_path = (["haxe"], "Int32") }, [] )
  1880. | TInst({ cl_path = ([], "Int") },[])
  1881. | TAbstract ({ a_path = ([], "Int") },[])
  1882. | TInst({ cl_path = ([], "String") },[]) ->
  1883. (List.exists (fun (c,_) ->
  1884. List.exists (fun expr -> match expr.eexpr with | TConst _ -> false | _ -> true ) c
  1885. ) cases)
  1886. | _ -> true
  1887. )
  1888. | _ -> assert false
  1889. ) true );
  1890. let native_arr_cl = get_cl ( get_type gen (["java"], "NativeArray") ) in
  1891. ExpressionUnwrap.configure gen (ExpressionUnwrap.traverse gen (fun e -> Some { eexpr = TVar(mk_temp gen "expr" e.etype, Some e); etype = gen.gcon.basic.tvoid; epos = e.epos }));
  1892. UnnecessaryCastsRemoval.configure gen;
  1893. IntDivisionSynf.configure gen (IntDivisionSynf.default_implementation gen true);
  1894. UnreachableCodeEliminationSynf.configure gen (UnreachableCodeEliminationSynf.traverse gen false true true true);
  1895. ArrayDeclSynf.configure gen (ArrayDeclSynf.default_implementation gen native_arr_cl);
  1896. let goto_special = alloc_var "__goto__" t_dynamic in
  1897. let label_special = alloc_var "__label__" t_dynamic in
  1898. SwitchBreakSynf.configure gen (SwitchBreakSynf.traverse gen
  1899. (fun e_loop n api ->
  1900. { 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] ) };
  1901. )
  1902. (fun e_break n api ->
  1903. { eexpr = TCall( mk_local goto_special e_break.epos, [ mk_int gen n e_break.epos ] ); etype = t_dynamic; epos = e_break.epos }
  1904. )
  1905. );
  1906. DefaultArguments.configure gen (DefaultArguments.traverse gen);
  1907. JavaSpecificSynf.configure gen (JavaSpecificSynf.traverse gen runtime_cl);
  1908. JavaSpecificESynf.configure gen (JavaSpecificESynf.traverse gen runtime_cl);
  1909. (* add native String as a String superclass *)
  1910. let str_cl = match gen.gcon.basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in
  1911. str_cl.cl_super <- Some (get_cl (get_type gen (["haxe";"lang"], "NativeString")), []);
  1912. let mkdir dir = if not (Sys.file_exists dir) then Unix.mkdir dir 0o755 in
  1913. mkdir gen.gcon.file;
  1914. mkdir (gen.gcon.file ^ "/src");
  1915. (* add resources array *)
  1916. (try
  1917. let res = get_cl (Hashtbl.find gen.gtypes (["haxe"], "Resource")) in
  1918. let cf = PMap.find "content" res.cl_statics in
  1919. let res = ref [] in
  1920. Hashtbl.iter (fun name v ->
  1921. res := { eexpr = TConst(TString name); etype = gen.gcon.basic.tstring; epos = Ast.null_pos } :: !res;
  1922. let full_path = gen.gcon.file ^ "/src/" ^ name in
  1923. mkdir_from_path full_path;
  1924. let f = open_out full_path in
  1925. output_string f v;
  1926. close_out f
  1927. ) gen.gcon.resources;
  1928. cf.cf_expr <- Some ({ eexpr = TArrayDecl(!res); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = Ast.null_pos })
  1929. with | Not_found -> ());
  1930. run_filters gen;
  1931. TypeParams.RenameTypeParameters.run gen;
  1932. let t = Common.timer "code generation" in
  1933. generate_modules_t gen "java" "src" change_path module_gen;
  1934. dump_descriptor gen ("hxjava_build.txt") path_s (fun md -> path_s (t_infos md).mt_path);
  1935. if ( not (Common.defined gen.gcon Define.NoCompilation) ) then begin
  1936. let old_dir = Sys.getcwd() in
  1937. Sys.chdir gen.gcon.file;
  1938. let cmd = "haxelib run hxjava hxjava_build.txt --haxe-version " ^ (string_of_int gen.gcon.version) in
  1939. print_endline cmd;
  1940. if gen.gcon.run_command cmd <> 0 then failwith "Build failed";
  1941. Sys.chdir old_dir;
  1942. end;
  1943. t()
  1944. (* end of configure function *)
  1945. let before_generate con =
  1946. let java_ver = try
  1947. int_of_string (PMap.find "java_ver" con.defines)
  1948. with | Not_found ->
  1949. Common.define_value con Define.JavaVer "7";
  1950. 7
  1951. in
  1952. if java_ver < 5 then failwith ("Java version is defined to target Java " ^ string_of_int java_ver ^ ", but the compiler can only output code to versions equal or superior to Java 5");
  1953. let rec loop i =
  1954. Common.raw_define con ("java" ^ (string_of_int i));
  1955. if i > 0 then loop (i - 1)
  1956. in
  1957. loop java_ver;
  1958. ()
  1959. let generate con =
  1960. let exists = ref false in
  1961. con.java_libs <- List.map (fun (file,std,close,la,gr) ->
  1962. if String.ends_with file "hxjava-std.jar" then begin
  1963. exists := true;
  1964. (file,true,close,la,gr)
  1965. end else
  1966. (file,std,close,la,gr)) con.java_libs;
  1967. if not !exists then
  1968. failwith "Your version of hxjava is outdated. Please update it by running: `haxelib update hxjava`";
  1969. let gen = new_ctx con in
  1970. gen.gallow_tp_dynamic_conversion <- true;
  1971. let basic = con.basic in
  1972. (* make the basic functions in java *)
  1973. let basic_fns =
  1974. [
  1975. mk_class_field "equals" (TFun(["obj",false,t_dynamic], basic.tbool)) true Ast.null_pos (Method MethNormal) [];
  1976. mk_class_field "toString" (TFun([], basic.tstring)) true Ast.null_pos (Method MethNormal) [];
  1977. mk_class_field "hashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) [];
  1978. mk_class_field "wait" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
  1979. mk_class_field "notify" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
  1980. mk_class_field "notifyAll" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
  1981. ] in
  1982. List.iter (fun cf -> gen.gbase_class_fields <- PMap.add cf.cf_name cf gen.gbase_class_fields) basic_fns;
  1983. (try
  1984. configure gen
  1985. with | TypeNotFound path -> con.error ("Error. Module '" ^ (path_s path) ^ "' is required and was not included in build.") Ast.null_pos);
  1986. debug_mode := false
  1987. (** Java lib *)
  1988. open JData
  1989. type java_lib_ctx = {
  1990. jcom : Common.context;
  1991. (* current tparams context *)
  1992. mutable jtparams : jtypes list;
  1993. }
  1994. exception ConversionError of string * pos
  1995. let error s p = raise (ConversionError (s, p))
  1996. let jname_to_hx name =
  1997. let name =
  1998. if name <> "" && (String.get name 0 < 'A' || String.get name 0 > 'Z') then
  1999. Char.escaped (Char.uppercase (String.get name 0)) ^ String.sub name 1 (String.length name - 1)
  2000. else
  2001. name
  2002. in
  2003. (* handle non-inner classes with same final name as non-inner *)
  2004. let name = String.concat "__" (String.nsplit name "_") in
  2005. (* handle with inner classes *)
  2006. String.map (function | '$' -> '_' | c -> c) name
  2007. let normalize_pack pack =
  2008. List.map (function
  2009. | "" -> ""
  2010. | str when String.get str 0 >= 'A' && String.get str 0 <= 'Z' ->
  2011. String.lowercase str
  2012. | str -> str
  2013. ) pack
  2014. let jpath_to_hx (pack,name) = match pack, name with
  2015. | ["haxe";"root"], name -> [], name
  2016. | "com" :: ("oracle" | "sun") :: _, _
  2017. | "javax" :: _, _
  2018. | "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _
  2019. | "sun" :: _, _
  2020. | "sunw" :: _, _ -> "java" :: normalize_pack pack, jname_to_hx name
  2021. | pack, name -> normalize_pack pack, jname_to_hx name
  2022. let hxname_to_j name =
  2023. let name = String.implode (List.rev (String.explode name)) in
  2024. let fl = String.nsplit name "__" in
  2025. let fl = List.map (String.map (fun c -> if c = '_' then '$' else c)) fl in
  2026. let ret = String.concat "_" fl in
  2027. String.implode (List.rev (String.explode ret))
  2028. let hxpath_to_j (pack,name) = match pack, name with
  2029. | "java" :: "com" :: ("oracle" | "sun") :: _, _
  2030. | "java" :: "javax" :: _, _
  2031. | "java" :: "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _
  2032. | "java" :: "sun" :: _, _
  2033. | "java" :: "sunw" :: _, _ -> List.tl pack, hxname_to_j name
  2034. | pack, name -> pack, hxname_to_j name
  2035. let real_java_path ctx (pack,name) =
  2036. path_s (pack, name)
  2037. let lookup_jclass com path =
  2038. let path = jpath_to_hx path in
  2039. List.fold_right (fun (_,_,_,_,get_raw_class) acc ->
  2040. match acc with
  2041. | None -> get_raw_class path
  2042. | Some p -> Some p
  2043. ) com.java_libs None
  2044. let mk_type_path ctx path params =
  2045. let name, sub = try
  2046. let p, _ = String.split (snd path) "$" in
  2047. jname_to_hx p, Some (jname_to_hx (snd path))
  2048. with | Invalid_string ->
  2049. jname_to_hx (snd path), None
  2050. in
  2051. CTPath {
  2052. tpackage = fst (jpath_to_hx path);
  2053. tname = name;
  2054. tparams = params;
  2055. tsub = sub;
  2056. }
  2057. let has_tparam name params = List.exists(fun (n,_,_) -> n = name) params
  2058. let rec convert_arg ctx p arg =
  2059. match arg with
  2060. | TAny | TType (WSuper, _) -> TPType (mk_type_path ctx ([], "Dynamic") [])
  2061. | TType (_, jsig) -> TPType (convert_signature ctx p jsig)
  2062. and convert_signature ctx p jsig =
  2063. match jsig with
  2064. | TByte -> mk_type_path ctx (["java"; "types"], "Int8") []
  2065. | TChar -> mk_type_path ctx (["java"; "types"], "Char16") []
  2066. | TDouble -> mk_type_path ctx ([], "Float") []
  2067. | TFloat -> mk_type_path ctx ([], "Single") []
  2068. | TInt -> mk_type_path ctx ([], "Int") []
  2069. | TLong -> mk_type_path ctx (["haxe"], "Int64") []
  2070. | TShort -> mk_type_path ctx (["java"; "types"], "Int16") []
  2071. | TBool -> mk_type_path ctx ([], "Bool") []
  2072. | TObject ( (["haxe";"root"], name), args ) -> mk_type_path ctx ([], name) (List.map (convert_arg ctx p) args)
  2073. (** nullable types *)
  2074. | TObject ( (["java";"lang"], "Integer"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Int") []) ]
  2075. | TObject ( (["java";"lang"], "Double"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Float") []) ]
  2076. | TObject ( (["java";"lang"], "Single"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Single") []) ]
  2077. | TObject ( (["java";"lang"], "Boolean"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Bool") []) ]
  2078. | TObject ( (["java";"lang"], "Byte"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int8") []) ]
  2079. | TObject ( (["java";"lang"], "Character"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Char16") []) ]
  2080. | TObject ( (["java";"lang"], "Short"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int16") []) ]
  2081. | TObject ( (["java";"lang"], "Long"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["haxe"], "Int64") []) ]
  2082. (** other std types *)
  2083. | TObject ( (["java";"lang"], "Object"), [] ) -> mk_type_path ctx ([], "Dynamic") []
  2084. | TObject ( (["java";"lang"], "String"), [] ) -> mk_type_path ctx ([], "String") []
  2085. (** other types *)
  2086. | TObject ( path, [] ) ->
  2087. (match lookup_jclass ctx.jcom path with
  2088. | Some (jcl, _, _) -> mk_type_path ctx path (List.map (fun _ -> convert_arg ctx p TAny) jcl.ctypes)
  2089. | None -> mk_type_path ctx path [])
  2090. | TObject ( path, args ) -> mk_type_path ctx path (List.map (convert_arg ctx p) args)
  2091. | TObjectInner (pack, (name, params) :: inners) ->
  2092. let actual_param = match List.rev inners with
  2093. | (_, p) :: _ -> p
  2094. | _ -> assert false in
  2095. mk_type_path ctx (pack, name ^ "$" ^ String.concat "$" (List.map fst inners)) (List.map (fun param -> convert_arg ctx p param) actual_param)
  2096. | TObjectInner (pack, inners) -> assert false
  2097. | TArray (jsig, _) -> mk_type_path ctx (["java"], "NativeArray") [ TPType (convert_signature ctx p jsig) ]
  2098. | TMethod _ -> JReader.error "TMethod cannot be converted directly into Complex Type"
  2099. | TTypeParameter s -> (match ctx.jtparams with
  2100. | cur :: others ->
  2101. if has_tparam s cur then
  2102. mk_type_path ctx ([], s) []
  2103. else begin
  2104. if ctx.jcom.verbose && not(List.exists (has_tparam s) others) then print_endline ("Type parameter " ^ s ^ " was not found while building type!");
  2105. mk_type_path ctx ([], "Dynamic") []
  2106. end
  2107. | _ ->
  2108. if ctx.jcom.verbose then print_endline ("Empty type parameter stack!");
  2109. mk_type_path ctx ([], "Dynamic") [])
  2110. let convert_constant ctx p const =
  2111. Option.map_default (function
  2112. | ConstString s -> Some (EConst (String s), p)
  2113. | ConstInt i -> Some (EConst (Int (Printf.sprintf "%ld" i)), p)
  2114. | ConstFloat f | ConstDouble f -> Some (EConst (Float (Printf.sprintf "%E" f)), p)
  2115. | _ -> None) None const
  2116. let rec same_sig parent jsig =
  2117. match jsig with
  2118. | TObject (p,targs) -> parent = p || List.exists (function | TType (_,s) -> same_sig parent s | _ -> false) targs
  2119. | TObjectInner(p, ntargs) ->
  2120. parent = (p, String.concat "$" (List.map fst ntargs)) ||
  2121. List.exists (fun (_,targs) -> List.exists (function | TType(_,s) -> same_sig parent s | _ -> false) targs) ntargs
  2122. | TArray(s,_) -> same_sig parent s
  2123. | _ -> false
  2124. let convert_param ctx p parent param =
  2125. let name, constraints = match param with
  2126. | (name, Some extends_sig, implem_sig) ->
  2127. name, extends_sig :: implem_sig
  2128. | (name, None, implemem_sig) ->
  2129. name, implemem_sig
  2130. in
  2131. let constraints = List.map (fun s -> if same_sig parent s then (TObject( (["java";"lang"], "Object"), [])) else s) constraints in
  2132. {
  2133. tp_name = name;
  2134. tp_params = [];
  2135. tp_constraints = List.map (convert_signature ctx p) constraints;
  2136. }
  2137. let get_type_path ctx ct = match ct with | CTPath p -> p | _ -> assert false
  2138. let is_override field =
  2139. List.exists (function | AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), _ ) }] -> true | _ -> false) field.jf_attributes
  2140. let mk_override field =
  2141. { field with jf_attributes = ((AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), [] ); ann_elements = [] }]) :: field.jf_attributes) }
  2142. let del_override field =
  2143. { field with jf_attributes = List.filter (fun a -> not (is_override_attrib a)) field.jf_attributes }
  2144. let convert_java_enum ctx p pe =
  2145. let meta = ref [Meta.Native, [EConst (String (real_java_path ctx pe.cpath) ), p], p ] in
  2146. let data = ref [] in
  2147. List.iter (fun f ->
  2148. (* if List.mem JEnum f.jf_flags then *)
  2149. match f.jf_vmsignature with
  2150. | TObject( path, [] ) when path = pe.cpath && List.mem JStatic f.jf_flags && List.mem JFinal f.jf_flags ->
  2151. data := { ec_name = f.jf_name; ec_doc = None; ec_meta = []; ec_args = []; ec_pos = p; ec_params = []; ec_type = None; } :: !data;
  2152. | _ -> ()
  2153. ) pe.cfields;
  2154. EEnum {
  2155. d_name = jname_to_hx (snd pe.cpath);
  2156. d_doc = None;
  2157. d_params = []; (* enums never have type parameters *)
  2158. d_meta = !meta;
  2159. d_flags = [EExtern];
  2160. d_data = List.rev !data;
  2161. }
  2162. let convert_java_field ctx p jc field =
  2163. let p = { p with pfile = p.pfile ^" (" ^field.jf_name ^")" } in
  2164. let cff_doc = None in
  2165. let cff_pos = p in
  2166. let cff_meta = ref [] in
  2167. let cff_access = ref [] in
  2168. let cff_name = match field.jf_name with
  2169. | "<init>" -> "new"
  2170. | "<clinit>"-> raise Exit (* __init__ field *)
  2171. | name when String.length name > 5 ->
  2172. (match String.sub name 0 5 with
  2173. | "__hx_" | "this$" -> raise Exit
  2174. | _ -> name)
  2175. | name -> name
  2176. in
  2177. let jf_constant = ref field.jf_constant in
  2178. let readonly = ref false in
  2179. List.iter (function
  2180. | JPublic -> cff_access := APublic :: !cff_access
  2181. | JPrivate -> raise Exit (* private instances aren't useful on externs *)
  2182. | JProtected -> cff_access := APrivate :: !cff_access
  2183. | JStatic -> cff_access := AStatic :: !cff_access
  2184. | JFinal ->
  2185. cff_meta := (Meta.Final, [], p) :: !cff_meta;
  2186. (match field.jf_kind, field.jf_vmsignature, field.jf_constant with
  2187. | JKField, TObject _, _ ->
  2188. jf_constant := None
  2189. | JKField, _, Some _ ->
  2190. readonly := true;
  2191. jf_constant := None;
  2192. | _ -> jf_constant := None)
  2193. (* | JSynchronized -> cff_meta := (Meta.Synchronized, [], p) :: !cff_meta *)
  2194. | JVolatile -> cff_meta := (Meta.Volatile, [], p) :: !cff_meta
  2195. | JTransient -> cff_meta := (Meta.Transient, [], p) :: !cff_meta
  2196. (* | JVarArgs -> cff_meta := (Meta.VarArgs, [], p) :: !cff_meta *)
  2197. | _ -> ()
  2198. ) field.jf_flags;
  2199. List.iter (function
  2200. | AttrDeprecated when jc.cpath <> (["java";"util"],"Date") -> cff_meta := (Meta.Deprecated, [], p) :: !cff_meta
  2201. (* TODO: pass anotations as @:meta *)
  2202. | AttrVisibleAnnotations ann ->
  2203. List.iter (function
  2204. | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } ->
  2205. cff_access := AOverride :: !cff_access
  2206. | _ -> ()
  2207. ) ann
  2208. | _ -> ()
  2209. ) field.jf_attributes;
  2210. let kind = match field.jf_kind with
  2211. | JKField when !readonly ->
  2212. FProp ("default", "null", Some (convert_signature ctx p field.jf_signature), None)
  2213. | JKField ->
  2214. FVar (Some (convert_signature ctx p field.jf_signature), None)
  2215. | JKMethod ->
  2216. match field.jf_signature with
  2217. | TMethod (args, ret) ->
  2218. let old_types = ctx.jtparams in
  2219. (match ctx.jtparams with
  2220. | c :: others -> ctx.jtparams <- (c @ field.jf_types) :: others
  2221. | [] -> ctx.jtparams <- field.jf_types :: []);
  2222. let i = ref 0 in
  2223. let args = List.map (fun s ->
  2224. incr i;
  2225. "param" ^ string_of_int !i, false, Some(convert_signature ctx p s), None
  2226. ) args in
  2227. let t = Option.map_default (convert_signature ctx p) (mk_type_path ctx ([], "Void") []) ret in
  2228. cff_meta := (Meta.Overload, [], p) :: !cff_meta;
  2229. let types = List.map (function
  2230. | (name, Some ext, impl) ->
  2231. {
  2232. tp_name = name;
  2233. tp_params = [];
  2234. tp_constraints = List.map (convert_signature ctx p) (ext :: impl);
  2235. }
  2236. | (name, None, impl) ->
  2237. {
  2238. tp_name = name;
  2239. tp_params = [];
  2240. tp_constraints = List.map (convert_signature ctx p) (impl);
  2241. }
  2242. ) field.jf_types in
  2243. ctx.jtparams <- old_types;
  2244. FFun ({
  2245. f_params = types;
  2246. f_args = args;
  2247. f_type = Some t;
  2248. f_expr = None
  2249. })
  2250. | _ -> error "Method signature was expected" p
  2251. in
  2252. let cff_name, cff_meta =
  2253. if String.get cff_name 0 = '%' then
  2254. let name = (String.sub cff_name 1 (String.length cff_name - 1)) in
  2255. "_" ^ name,
  2256. (Meta.Native, [EConst (String (name) ), cff_pos], cff_pos) :: !cff_meta
  2257. else
  2258. cff_name, !cff_meta
  2259. in
  2260. {
  2261. cff_name = cff_name;
  2262. cff_doc = cff_doc;
  2263. cff_pos = cff_pos;
  2264. cff_meta = cff_meta;
  2265. cff_access = !cff_access;
  2266. cff_kind = kind
  2267. }
  2268. let rec japply_params params jsig = match params with
  2269. | [] -> jsig
  2270. | _ -> match jsig with
  2271. | TTypeParameter s -> (try
  2272. List.assoc s params
  2273. with | Not_found -> jsig)
  2274. | TObject(p,tl) ->
  2275. TObject(p, args params tl)
  2276. | TObjectInner(sl, stll) ->
  2277. TObjectInner(sl, List.map (fun (s,tl) -> (s, args params tl)) stll)
  2278. | TArray(s,io) ->
  2279. TArray(japply_params params s, io)
  2280. | TMethod(sl, sopt) ->
  2281. TMethod(List.map (japply_params params) sl, Option.map (japply_params params) sopt)
  2282. | _ -> jsig
  2283. and args params tl = match params with
  2284. | [] -> tl
  2285. | _ -> List.map (function
  2286. | TAny -> TAny
  2287. | TType(w,s) -> TType(w,japply_params params s)) tl
  2288. let mk_params jtypes = List.map (fun (s,_,_) -> (s,TTypeParameter s)) jtypes
  2289. let convert_java_class ctx p jc =
  2290. match List.mem JEnum jc.cflags with
  2291. | true -> (* is enum *)
  2292. convert_java_enum ctx p jc
  2293. | false ->
  2294. let flags = ref [HExtern] in
  2295. (* todo: instead of JavaNative, use more specific definitions *)
  2296. let meta = ref [Meta.JavaNative, [], p; Meta.Native, [EConst (String (real_java_path ctx jc.cpath) ), p], p] in
  2297. let is_interface = ref false in
  2298. List.iter (fun f -> match f with
  2299. | JFinal -> meta := (Meta.Final, [], p) :: !meta
  2300. | JInterface ->
  2301. is_interface := true;
  2302. flags := HInterface :: !flags
  2303. | JAbstract -> meta := (Meta.Abstract, [], p) :: !meta
  2304. | JAnnotation -> meta := (Meta.Annotation, [], p) :: !meta
  2305. | _ -> ()
  2306. ) jc.cflags;
  2307. (match jc.csuper with
  2308. | TObject( (["java";"lang"], "Object"), _ ) -> ()
  2309. | TObject( (["haxe";"lang"], "HxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta
  2310. | _ -> flags := HExtends (get_type_path ctx (convert_signature ctx p jc.csuper)) :: !flags
  2311. );
  2312. List.iter (fun i ->
  2313. match i with
  2314. | TObject ( (["haxe";"lang"], "IHxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta
  2315. | _ -> flags :=
  2316. if !is_interface then
  2317. HExtends (get_type_path ctx (convert_signature ctx p i)) :: !flags
  2318. else
  2319. HImplements (get_type_path ctx (convert_signature ctx p i)) :: !flags
  2320. ) jc.cinterfaces;
  2321. let fields = ref [] in
  2322. let jfields = ref [] in
  2323. if jc.cpath <> (["java";"lang"], "CharSequence") then
  2324. List.iter (fun f ->
  2325. try
  2326. if !is_interface && List.mem JStatic f.jf_flags then
  2327. ()
  2328. else begin
  2329. fields := convert_java_field ctx p jc f :: !fields;
  2330. jfields := f :: !jfields
  2331. end
  2332. with
  2333. | Exit -> ()
  2334. ) (jc.cfields @ jc.cmethods);
  2335. EClass {
  2336. d_name = jname_to_hx (snd jc.cpath);
  2337. d_doc = None;
  2338. d_params = List.map (convert_param ctx p jc.cpath) jc.ctypes;
  2339. d_meta = !meta;
  2340. d_flags = !flags;
  2341. d_data = !fields;
  2342. }
  2343. let create_ctx com =
  2344. {
  2345. jcom = com;
  2346. jtparams = [];
  2347. }
  2348. let rec has_type_param = function
  2349. | TTypeParameter _ -> true
  2350. | TMethod (lst, opt) -> List.exists has_type_param lst || Option.map_default has_type_param false opt
  2351. | TArray (s,_) -> has_type_param s
  2352. | TObjectInner (_, stpl) -> List.exists (fun (_,sigs) -> List.exists has_type_param_arg sigs) stpl
  2353. | TObject(_, pl) -> List.exists has_type_param_arg pl
  2354. | _ -> false
  2355. and has_type_param_arg = function | TType(_,s) -> has_type_param s | _ -> false
  2356. let rec japply_params jparams jsig = match jparams with
  2357. | [] -> jsig
  2358. | _ ->
  2359. match jsig with
  2360. | TObject(path,p) ->
  2361. TObject(path, List.map (japply_params_tp jparams ) p)
  2362. | TObjectInner(sl,stargl) ->
  2363. TObjectInner(sl,List.map (fun (s,targ) -> (s, List.map (japply_params_tp jparams) targ)) stargl)
  2364. | TArray(jsig,io) ->
  2365. TArray(japply_params jparams jsig,io)
  2366. | TMethod(args,ret) ->
  2367. TMethod(List.map (japply_params jparams ) args, Option.map (japply_params jparams ) ret)
  2368. | TTypeParameter s -> (try
  2369. List.assoc s jparams
  2370. with | Not_found -> jsig)
  2371. | _ -> jsig
  2372. and japply_params_tp jparams jtype_argument = match jtype_argument with
  2373. | TAny -> TAny
  2374. | TType(w,jsig) -> TType(w,japply_params jparams jsig)
  2375. let mk_jparams jtypes params = match jtypes, params with
  2376. | [], [] -> []
  2377. | _, [] -> List.map (fun (s,_,_) -> s, TObject( (["java";"lang"], "Object"), [] ) ) jtypes
  2378. | _ -> List.map2 (fun (s,_,_) jt -> match jt with
  2379. | TAny -> s, TObject((["java";"lang"],"Object"),[])
  2380. | TType(_,jsig) -> s, jsig) jtypes params
  2381. let rec compatible_signature_arg ?arg_test f1 f2 =
  2382. let arg_test = match arg_test with
  2383. | None -> (fun _ _ -> true)
  2384. | Some a -> a
  2385. in
  2386. if f1 = f2 then
  2387. true
  2388. else match f1, f2 with
  2389. | TObject(p,a), TObject(p2,a2) -> p = p2 && arg_test a a2
  2390. | TObjectInner(sl, stal), TObjectInner(sl2, stal2) -> sl = sl2 && List.map fst stal = List.map fst stal2
  2391. | TArray(s,_) , TArray(s2,_) -> compatible_signature_arg s s2
  2392. | TTypeParameter t1 , TTypeParameter t2 -> t1 = t2
  2393. | _ -> false
  2394. let rec compatible_param p1 p2 = match p1, p2 with
  2395. | TType (_,s1), TType(_,s2) -> compatible_signature_arg ~arg_test:compatible_tparams s1 s2
  2396. | TAny, TType(_, TObject( (["java";"lang"],"Object"), _ )) -> true
  2397. | TType(_, TObject( (["java";"lang"],"Object"), _ )), TAny -> true
  2398. | _ -> false
  2399. and compatible_tparams p1 p2 = try match p1, p2 with
  2400. | [], [] -> true
  2401. | _, [] ->
  2402. let p2 = List.map (fun _ -> TAny) p1 in
  2403. List.for_all2 compatible_param p1 p2
  2404. | [], _ ->
  2405. let p1 = List.map (fun _ -> TAny) p2 in
  2406. List.for_all2 compatible_param p1 p2
  2407. | _, _ ->
  2408. List.for_all2 compatible_param p1 p2
  2409. with | Invalid_argument("List.for_all2") -> false
  2410. let get_adapted_sig f f2 = match f.jf_types with
  2411. | [] ->
  2412. f.jf_signature
  2413. | _ ->
  2414. let jparams = mk_jparams f.jf_types (List.map (fun (s,_,_) -> TType(WNone, TTypeParameter s)) f2.jf_types) in
  2415. japply_params jparams f.jf_signature
  2416. let compatible_methods f1 f2 =
  2417. if List.length f1.jf_types <> List.length f2.jf_types then
  2418. false
  2419. else match (get_adapted_sig f1 f2), f2.jf_signature with
  2420. | TMethod(a1,_), TMethod(a2,_) when List.length a1 = List.length a2 ->
  2421. List.for_all2 compatible_signature_arg a1 a2
  2422. | _ -> false
  2423. let jcl_from_jsig com jsig =
  2424. let path, params = match jsig with
  2425. | TObject(path, params) ->
  2426. path,params
  2427. | TObjectInner(sl, stll) ->
  2428. let last_params = ref [] in
  2429. let real_path = sl, String.concat "$" (List.map (fun (s,p) -> last_params := p; s) stll) in
  2430. real_path, !last_params
  2431. | _ -> raise Not_found
  2432. in
  2433. match lookup_jclass com path with
  2434. | None -> raise Not_found
  2435. | Some(c,_,_) -> c,params
  2436. let jclass_with_params com cls params = try
  2437. match cls.ctypes with
  2438. | [] -> cls
  2439. | _ ->
  2440. let jparams = mk_jparams cls.ctypes params in
  2441. { cls with
  2442. cfields = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cfields;
  2443. cmethods = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cmethods;
  2444. csuper = japply_params jparams cls.csuper;
  2445. cinterfaces = List.map (japply_params jparams) cls.cinterfaces;
  2446. }
  2447. with Invalid_argument("List.map2") ->
  2448. if com.verbose then prerr_endline ("Differing parameters for class: " ^ path_s cls.cpath);
  2449. cls
  2450. let is_object = function | TObject( (["java";"lang"], "Object"), [] ) -> true | _ -> false
  2451. let is_tobject = function | TObject _ | TObjectInner _ -> true | _ -> false
  2452. let simplify_args args =
  2453. if List.for_all (function | TAny -> true | _ -> false) args then [] else args
  2454. let compare_type com s1 s2 =
  2455. if s1 = s2 then
  2456. 0
  2457. else if not (is_tobject s1) then
  2458. if is_tobject s2 then (* Dynamic *)
  2459. 1
  2460. else if compatible_signature_arg s1 s2 then
  2461. 0
  2462. else
  2463. raise Exit
  2464. else if not (is_tobject s2) then
  2465. -1
  2466. else begin
  2467. let rec loop ?(first_error=true) s1 s2 : bool =
  2468. if is_object s1 then
  2469. s1 = s2
  2470. else if compatible_signature_arg s1 s2 then begin
  2471. let p1, p2 = match s1, s2 with
  2472. | TObject(_, p1), TObject(_,p2) ->
  2473. p1, p2
  2474. | TObjectInner(_, npl1), TObjectInner(_, npl2) ->
  2475. snd (List.hd (List.rev npl1)), snd (List.hd (List.rev npl2))
  2476. | _ -> assert false (* not tobject *)
  2477. in
  2478. let p1, p2 = simplify_args p1, simplify_args p2 in
  2479. let lp1 = List.length p1 in
  2480. let lp2 = List.length p2 in
  2481. if lp1 > lp2 then
  2482. true
  2483. else if lp2 > lp1 then
  2484. false
  2485. else begin
  2486. (* if compatible tparams, it's fine *)
  2487. if not (compatible_tparams p1 p2) then
  2488. raise Exit; (* meaning: found, but incompatible type parameters *)
  2489. true
  2490. end
  2491. end else try
  2492. let c, p = jcl_from_jsig com s1 in
  2493. let jparams = mk_jparams c.ctypes p in
  2494. let super = japply_params jparams c.csuper in
  2495. let implements = List.map (japply_params jparams) c.cinterfaces in
  2496. loop ~first_error:first_error super s2 || List.exists (fun super -> loop ~first_error:first_error super s2) implements
  2497. with | Not_found ->
  2498. if com.verbose then begin
  2499. prerr_endline ("-java-lib: The type " ^ (s_sig s1) ^ " is referred but was not found. Compilation may not occur correctly.");
  2500. prerr_endline "Did you forget to include a needed lib?"
  2501. end;
  2502. if first_error then
  2503. not (loop ~first_error:false s2 s1)
  2504. else
  2505. false
  2506. in
  2507. if loop s1 s2 then
  2508. if loop s2 s1 then
  2509. 0
  2510. else
  2511. 1
  2512. else
  2513. if loop s2 s1 then
  2514. -1
  2515. else
  2516. -2
  2517. end
  2518. (* given a list of same overload functions, choose the best (or none) *)
  2519. let select_best com flist =
  2520. let rec loop cur_best = function
  2521. | [] ->
  2522. Some cur_best
  2523. | f :: flist -> match get_adapted_sig f cur_best, cur_best.jf_signature with
  2524. | TMethod(_,Some r), TMethod(_, Some r2) -> (try
  2525. match compare_type com r r2 with
  2526. | 0 -> (* same type - select any of them *)
  2527. loop cur_best flist
  2528. | 1 ->
  2529. loop f flist
  2530. | -1 ->
  2531. loop cur_best flist
  2532. | -2 -> (* error - no type is compatible *)
  2533. if com.verbose then prerr_endline (f.jf_name ^ ": The types " ^ (s_sig r) ^ " and " ^ (s_sig r2) ^ " are incompatible");
  2534. (* bet that the current best has "beaten" other types *)
  2535. loop cur_best flist
  2536. | _ -> assert false
  2537. with | Exit -> (* incompatible type parameters *)
  2538. (* error mode *)
  2539. if com.verbose then prerr_endline (f.jf_name ^ ": Incompatible argument return signatures: " ^ (s_sig r) ^ " and " ^ (s_sig r2));
  2540. None)
  2541. | TMethod _, _ -> (* select the method *)
  2542. loop f flist
  2543. | _ ->
  2544. loop cur_best flist
  2545. in
  2546. match loop (List.hd flist) (List.tl flist) with
  2547. | Some f ->
  2548. Some f
  2549. | None -> match List.filter (fun f -> not (is_override f)) flist with
  2550. (* error mode; take off all override methods *)
  2551. | [] -> None
  2552. | f :: [] -> Some f
  2553. | f :: flist -> Some f (* pick one *)
  2554. let normalize_jclass com cls =
  2555. (* search static / non-static name clash *)
  2556. let nonstatics = ref [] in
  2557. List.iter (fun f ->
  2558. if not(List.mem JStatic f.jf_flags) then nonstatics := f :: !nonstatics
  2559. ) (cls.cfields @ cls.cmethods);
  2560. (* we won't be able to deal correctly with field's type parameters *)
  2561. (* since java sometimes overrides / implements crude (ie no type parameters) versions *)
  2562. (* and interchanges between them *)
  2563. (* let methods = List.map (fun f -> let f = del_override f in if f.jf_types <> [] then { f with jf_types = []; jf_signature = f.jf_vmsignature } else f ) cls.cmethods in *)
  2564. (* let pth = path_s cls.cpath in *)
  2565. let methods = List.map (fun f -> del_override f ) cls.cmethods in
  2566. (* take off duplicate overload signature class fields from current class *)
  2567. let cmethods = ref methods in
  2568. let all_methods = ref methods in
  2569. let all_fields = ref cls.cfields in
  2570. let super_fields = ref [] in
  2571. let super_methods = ref [] in
  2572. (* fix overrides *)
  2573. let rec loop cls = try
  2574. match cls.csuper with
  2575. | TObject((["java";"lang"],"Object"),_) -> ()
  2576. | _ ->
  2577. let cls, params = jcl_from_jsig com cls.csuper in
  2578. let cls = jclass_with_params com cls params in
  2579. List.iter (fun f -> if not (List.mem JStatic f.jf_flags) then nonstatics := f :: !nonstatics) (cls.cfields @ cls.cmethods);
  2580. super_methods := cls.cmethods @ !super_methods;
  2581. all_methods := cls.cmethods @ !all_methods;
  2582. all_fields := cls.cfields @ !all_fields;
  2583. super_fields := cls.cfields @ !super_fields;
  2584. let overriden = ref [] in
  2585. cmethods := List.map (fun jm ->
  2586. (* TODO rewrite/standardize empty spaces *)
  2587. if not (is_override jm) && not(List.mem JStatic jm.jf_flags) && List.exists (fun msup ->
  2588. let ret = msup.jf_name = jm.jf_name && not(List.mem JStatic msup.jf_flags) && compatible_methods msup jm in
  2589. if ret then begin
  2590. let f = mk_override msup in
  2591. overriden := { f with jf_flags = jm.jf_flags } :: !overriden
  2592. end;
  2593. ret
  2594. ) cls.cmethods then
  2595. mk_override jm
  2596. else
  2597. jm
  2598. ) !cmethods;
  2599. cmethods := !overriden @ !cmethods;
  2600. loop cls
  2601. with | Not_found -> ()
  2602. in
  2603. if not (List.mem JInterface cls.cflags) then begin
  2604. cmethods := List.filter (fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags) !cmethods;
  2605. all_fields := List.filter (fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags) !all_fields;
  2606. super_fields := List.filter (fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags) !super_fields;
  2607. end;
  2608. loop cls;
  2609. (* look for interfaces and add missing implementations (may happen on abstracts or by vmsig differences *)
  2610. let added_interface_fields = ref [] in
  2611. let rec loop_interface abstract cls iface = try
  2612. match iface with
  2613. | TObject ((["java";"lang"],"Object"), _) -> ()
  2614. | TObject (path,_) when path = cls.cpath -> ()
  2615. | _ ->
  2616. let cif, params = jcl_from_jsig com iface in
  2617. let cif = jclass_with_params com cif params in
  2618. List.iter (fun jf ->
  2619. if not(List.mem JStatic jf.jf_flags) && not (List.exists (fun jf2 -> jf.jf_name = jf2.jf_name && not (List.mem JStatic jf2.jf_flags) && jf.jf_signature = jf2.jf_signature) !all_methods) then begin
  2620. let jf = if abstract then del_override jf else jf in
  2621. let jf = { jf with jf_flags = JPublic :: jf.jf_flags } in (* interfaces implementations are always public *)
  2622. added_interface_fields := jf :: !added_interface_fields;
  2623. cmethods := jf :: !cmethods;
  2624. all_methods := jf :: !all_methods;
  2625. nonstatics := jf :: !nonstatics;
  2626. end
  2627. ) cif.cmethods;
  2628. List.iter (loop_interface abstract cif) cif.cinterfaces;
  2629. with Not_found -> ()
  2630. in
  2631. (* another pass: *)
  2632. (* if List.mem JAbstract cls.cflags then List.iter loop_interface cls.cinterfaces; *)
  2633. (* if not (List.mem JInterface cls.cflags) then *)
  2634. List.iter (loop_interface (List.mem JAbstract cls.cflags) cls) cls.cinterfaces;
  2635. (* for each added field in the interface, lookup in super_methods possible methods to include *)
  2636. (* so we can choose the better method still *)
  2637. List.iter (fun im ->
  2638. let f = List.find_all (fun jf -> jf.jf_name = im.jf_name && compatible_methods jf im) !super_methods in
  2639. let f = List.map mk_override f in
  2640. cmethods := f @ !cmethods
  2641. ) !added_interface_fields;
  2642. (* take off equals, hashCode and toString from interface *)
  2643. if List.mem JInterface cls.cflags then cmethods := List.filter (fun jf -> match jf.jf_name, jf.jf_vmsignature with
  2644. | "equals", TMethod([TObject( (["java";"lang"],"Object"), _)],_)
  2645. | "hashCode", TMethod([], _)
  2646. | "toString", TMethod([], _) -> false
  2647. | _ -> true
  2648. ) !cmethods;
  2649. (* change field name to not collide with haxe keywords *)
  2650. let map_field f =
  2651. let change = match f.jf_name with
  2652. | "callback" | "cast" | "extern" | "function" | "in" | "typedef" | "using" | "var" | "untyped" | "inline" -> true
  2653. | _ when List.mem JStatic f.jf_flags && List.exists (fun f2 -> f.jf_name = f2.jf_name) !nonstatics -> true
  2654. | _ -> false
  2655. in
  2656. if change then
  2657. { f with jf_name = "%" ^ f.jf_name }
  2658. else
  2659. f
  2660. in
  2661. (* change static fields that have the same name as methods *)
  2662. let cfields = List.map map_field cls.cfields in
  2663. let cmethods = List.map map_field !cmethods in
  2664. (* take off variable fields that have the same name as methods *)
  2665. (* and take off variables that already have been declared *)
  2666. let filter_field f f2 = f != f2 && (List.mem JStatic f.jf_flags = List.mem JStatic f2.jf_flags) && f.jf_name = f2.jf_name && f2.jf_kind <> f.jf_kind in
  2667. let cfields = List.filter (fun f ->
  2668. if List.mem JStatic f.jf_flags then
  2669. not (List.exists (filter_field f) cmethods)
  2670. else
  2671. not (List.exists (filter_field f) !nonstatics) && not (List.exists (fun f2 -> f != f2 && f.jf_name = f2.jf_name && not (List.mem JStatic f2.jf_flags)) !all_fields) ) cfields
  2672. in
  2673. (* now filter any method that clashes with a field - on a superclass *)
  2674. let cmethods = List.filter (fun f ->
  2675. if List.mem JStatic f.jf_flags then
  2676. true
  2677. else
  2678. not (List.exists (filter_field f) !super_fields) ) cmethods
  2679. in
  2680. (* removing duplicate fields. They are there because of return type covariance in Java *)
  2681. (* Also, if a method overrides a previous definition, and changes a type parameters' variance, *)
  2682. (* we will take it off *)
  2683. (* this means that some rare codes will never compile on Haxe, but unless Haxe adds variance support *)
  2684. (* I can't see how this can be any different *)
  2685. let rec loop acc = function
  2686. | [] -> acc
  2687. | f :: cmeths ->
  2688. match List.partition (fun f2 -> f.jf_name = f2.jf_name && compatible_methods f f2) cmeths with
  2689. | [], cmeths ->
  2690. loop (f :: acc) cmeths
  2691. | flist, cmeths -> match select_best com (f :: flist) with
  2692. | None ->
  2693. loop acc cmeths
  2694. | Some f ->
  2695. loop (f :: acc) cmeths
  2696. in
  2697. (* last pass: take off all cfields that are internal / private (they won't be accessible anyway) *)
  2698. let cfields = List.filter(fun f -> List.exists (fun f -> f = JPublic || f = JProtected) f.jf_flags) cfields in
  2699. let cmethods = loop [] cmethods in
  2700. { cls with cfields = cfields; cmethods = cmethods }
  2701. let rec get_classes_dir pack dir ret =
  2702. Array.iter (fun f -> match (Unix.stat (dir ^"/"^ f)).st_kind with
  2703. | S_DIR ->
  2704. get_classes_dir (pack @ [f]) (dir ^"/"^ f) ret
  2705. | _ when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" ->
  2706. let path = jpath_to_hx (pack,f) in
  2707. ret := path :: !ret;
  2708. | _ -> ()
  2709. ) (Sys.readdir dir)
  2710. let get_classes_zip zip =
  2711. let ret = ref [] in
  2712. List.iter (function
  2713. | { Zip.is_directory = false; Zip.filename = f } when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" ->
  2714. (match List.rev (String.nsplit f "/") with
  2715. | clsname :: pack ->
  2716. let path = jpath_to_hx (List.rev pack, clsname) in
  2717. ret := path :: !ret
  2718. | _ ->
  2719. ret := ([], jname_to_hx f) :: !ret)
  2720. | _ -> ()
  2721. ) (Zip.entries zip);
  2722. !ret
  2723. let add_java_lib com file std =
  2724. let file = if Sys.file_exists file then
  2725. file
  2726. else try Common.find_file com file with
  2727. | Not_found -> try Common.find_file com (file ^ ".jar") with
  2728. | Not_found ->
  2729. failwith ("Java lib " ^ file ^ " not found")
  2730. in
  2731. let hxpack_to_jpack = Hashtbl.create 16 in
  2732. let get_raw_class, close, list_all_files =
  2733. (* check if it is a directory or jar file *)
  2734. match (Unix.stat file).st_kind with
  2735. | S_DIR -> (* open classes directly from directory *)
  2736. let rec iter_files pack dir path = try
  2737. let file = Unix.readdir dir in
  2738. if String.ends_with file ".class" then
  2739. let file = String.sub file 0 (String.length file - 6) in
  2740. Hashtbl.add hxpack_to_jpack (jpath_to_hx(pack,file)) (pack,file)
  2741. else if (Unix.stat file).st_kind = S_DIR then
  2742. let path = path ^"/"^ file in
  2743. let pack = pack @ [file] in
  2744. iter_files (pack @ [file]) (Unix.opendir path) path
  2745. with | End_of_file | Unix.Unix_error _ ->
  2746. Unix.closedir dir
  2747. in
  2748. iter_files [] (Unix.opendir file) file;
  2749. (fun (pack, name) ->
  2750. (* let pack, name = hxpath_to_j (pack,name) in *)
  2751. let real_path = file ^ "/" ^ (String.concat "/" pack) ^ "/" ^ (name ^ ".class") in
  2752. try
  2753. let data = Std.input_file ~bin:true real_path in
  2754. Some(JReader.parse_class (IO.input_string data), real_path, real_path)
  2755. with
  2756. | _ -> None), (fun () -> ()), (fun () -> let ret = ref [] in get_classes_dir [] file ret; !ret)
  2757. | _ -> (* open zip file *)
  2758. let closed = ref false in
  2759. let zip = ref (Zip.open_in file) in
  2760. let check_open () =
  2761. if !closed then begin
  2762. prerr_endline ("JAR file " ^ file ^ " already closed"); (* if this happens, find when *)
  2763. zip := Zip.open_in file;
  2764. closed := false
  2765. end
  2766. in
  2767. List.iter (function
  2768. | { Zip.is_directory = false; Zip.filename = filename } when String.ends_with filename ".class" ->
  2769. let pack = String.nsplit filename "/" in
  2770. (match List.rev pack with
  2771. | [] -> ()
  2772. | name :: pack ->
  2773. let name = String.sub name 0 (String.length name - 6) in
  2774. let pack = List.rev pack in
  2775. Hashtbl.add hxpack_to_jpack (jpath_to_hx (pack,name)) (pack,name))
  2776. | _ -> ()
  2777. ) (Zip.entries !zip);
  2778. (fun (pack, name) ->
  2779. (* let pack, name = hxpath_to_j (pack,name) in *)
  2780. check_open();
  2781. try
  2782. let location = (String.concat "/" (pack @ [name]) ^ ".class") in
  2783. let entry = Zip.find_entry !zip location in
  2784. let data = Zip.read_entry !zip entry in
  2785. Some(JReader.parse_class (IO.input_string data), file, file ^ "@" ^ location)
  2786. with
  2787. | Not_found ->
  2788. None),
  2789. (fun () -> if not !closed then begin closed := true; Zip.close_in !zip end),
  2790. (fun () -> check_open(); get_classes_zip !zip)
  2791. in
  2792. let cached_types = Hashtbl.create 12 in
  2793. let get_raw_class path =
  2794. try
  2795. Hashtbl.find cached_types path
  2796. with | Not_found ->
  2797. let pack, name = hxpath_to_j path in
  2798. let try_file (pack,name) =
  2799. match get_raw_class (pack,name) with
  2800. | None ->
  2801. Hashtbl.add cached_types path None;
  2802. None
  2803. | Some (i, p1, p2) ->
  2804. Hashtbl.add cached_types path (Some(i,p1,p2)); (* type loop normalization *)
  2805. let ret = Some (normalize_jclass com i, p1, p2) in
  2806. Hashtbl.replace cached_types path ret;
  2807. ret
  2808. in
  2809. let ret = try_file (pack,name) in
  2810. if ret = None && Hashtbl.mem hxpack_to_jpack path then
  2811. try_file (Hashtbl.find hxpack_to_jpack path)
  2812. else
  2813. ret
  2814. in
  2815. let rec build ctx path p types =
  2816. try
  2817. if List.mem path !types then
  2818. None
  2819. else begin
  2820. types := path :: !types;
  2821. match get_raw_class path, path with
  2822. | None, ([], c) -> build ctx (["haxe";"root"], c) p types
  2823. | None, _ -> None
  2824. | Some (cls, real_path, pos_path), _ ->
  2825. if com.verbose then print_endline ("Parsed Java class " ^ (path_s cls.cpath));
  2826. let old_types = ctx.jtparams in
  2827. ctx.jtparams <- cls.ctypes :: ctx.jtparams;
  2828. let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in
  2829. let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in
  2830. let ppath = hxpath_to_j path in
  2831. let inner = List.fold_left (fun acc (path,out,_,_) ->
  2832. let path = jpath_to_hx path in
  2833. (if out <> Some ppath then
  2834. acc
  2835. else match build ctx path p types with
  2836. | Some(_,(_, classes)) ->
  2837. classes @ acc
  2838. | _ -> acc);
  2839. ) [] cls.cinner_types in
  2840. (* build anonymous classes also *
  2841. let rec loop inner n =
  2842. match build ctx (fst path, snd path ^ "$" ^ (string_of_int n)) p types with
  2843. | Some(_,(_, classes)) ->
  2844. loop (classes @ inner) (n + 1)
  2845. | _ -> inner
  2846. in
  2847. let inner = loop inner 1 in*)
  2848. (* add _Statics class *)
  2849. let inner = try
  2850. if not (List.mem JInterface cls.cflags) then raise Not_found;
  2851. let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in
  2852. let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in
  2853. if not (smethods <> [] || sfields <> []) then raise Not_found;
  2854. let obj = TObject( (["java";"lang"],"Object"), []) in
  2855. let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in
  2856. match ncls with
  2857. | EClass c ->
  2858. (EClass { c with d_name = c.d_name ^ "_Statics" }, pos) :: inner
  2859. | _ -> assert false
  2860. with | Not_found ->
  2861. inner
  2862. in
  2863. let ret = Some ( real_path, (pack, (convert_java_class ctx pos cls, pos) :: inner) ) in
  2864. ctx.jtparams <- old_types;
  2865. ret
  2866. end
  2867. with
  2868. | JReader.Error_message msg ->
  2869. if com.verbose then prerr_endline ("Class reader failed: " ^ msg);
  2870. None
  2871. | e ->
  2872. if com.verbose then begin
  2873. (* prerr_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *)
  2874. prerr_endline (Printexc.to_string e)
  2875. end;
  2876. None
  2877. in
  2878. let build path p = build (create_ctx com) path p (ref [["java";"lang"], "String"]) in
  2879. let cached_files = ref None in
  2880. let list_all_files () = match !cached_files with
  2881. | None ->
  2882. let ret = list_all_files () in
  2883. cached_files := Some ret;
  2884. ret
  2885. | Some r -> r
  2886. in
  2887. (* TODO: add_dependency m mdep *)
  2888. com.load_extern_type <- com.load_extern_type @ [build];
  2889. com.java_libs <- (file, std, close, list_all_files, get_raw_class) :: com.java_libs