2
0

genjava.ml 136 KB

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