genjava.ml 136 KB

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