123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630 |
- (*
- * Copyright (C)2005-2013 Haxe Foundation
- *
- * Permission is hereby granted, free of charge, to any person obtaining a
- * copy of this software and associated documentation files (the "Software"),
- * to deal in the Software without restriction, including without limitation
- * the rights to use, copy, modify, merge, publish, distribute, sublicense,
- * and/or sell copies of the Software, and to permit persons to whom the
- * Software is furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
- * DEALINGS IN THE SOFTWARE.
- *)
- open JData
- open Unix
- open Ast
- open Common
- open Type
- open Gencommon
- open Gencommon.SourceWriter
- open Printf
- open Option
- open ExtString
- module SS = Set.Make(String)
- let is_boxed_type t = match follow t with
- | TInst ({ cl_path = (["java";"lang"], "Boolean") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Double") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Integer") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Byte") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Short") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Character") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> true
- | TAbstract ({ a_path = (["java";"lang"], "Boolean") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Double") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Integer") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Byte") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Short") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Character") }, [])
- | TAbstract ({ a_path = (["java";"lang"], "Float") }, []) -> true
- | _ -> false
- let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with
- | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool
- | TInst ({ cl_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat
- | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint
- | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) -> tbyte
- | TInst ({ cl_path = (["java";"lang"], "Short") }, []) -> tshort
- | TInst ({ cl_path = (["java";"lang"], "Character") }, []) -> tchar
- | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> tfloat
- | TAbstract ({ a_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool
- | TAbstract ({ a_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat
- | TAbstract ({ a_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint
- | TAbstract ({ a_path = (["java";"lang"], "Byte") }, []) -> tbyte
- | TAbstract ({ a_path = (["java";"lang"], "Short") }, []) -> tshort
- | TAbstract ({ a_path = (["java";"lang"], "Character") }, []) -> tchar
- | TAbstract ({ a_path = (["java";"lang"], "Float") }, []) -> tfloat
- | _ -> assert false
- let rec t_has_type_param t = match follow t with
- | TInst({ cl_kind = KTypeParameter _ }, []) -> true
- | TEnum(_, params)
- | TAbstract(_, params)
- | TInst(_, params) -> List.exists t_has_type_param params
- | TFun(f,ret) -> t_has_type_param ret || List.exists (fun (_,_,t) -> t_has_type_param t) f
- | _ -> false
- let is_type_param t = match follow t with
- | TInst({ cl_kind = KTypeParameter _ }, _) -> true
- | _ -> false
- let rec t_has_type_param_shallow last t = match follow t with
- | TInst({ cl_kind = KTypeParameter _ }, []) -> true
- | TEnum(_, params)
- | TAbstract(_, params)
- | TInst(_, params) when not last -> List.exists (t_has_type_param_shallow true) params
- | 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
- | _ -> false
- let rec replace_type_param t = match follow t with
- | TInst({ cl_kind = KTypeParameter _ }, []) -> t_dynamic
- | TEnum(e, params) -> TEnum(e, List.map replace_type_param params)
- | TAbstract(a, params) -> TAbstract(a, List.map replace_type_param params)
- | TInst(cl, params) -> TInst(cl, List.map replace_type_param params)
- | _ -> t
- let is_java_basic_type t =
- match follow t with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TAbstract( { a_path = ([], "Single") }, [] )
- | TAbstract( { a_path = (["java"], ("Int8" | "Int16" | "Char16" | "Int64")) }, [] )
- | TAbstract( { a_path = ([], "Int") }, [] )
- | TAbstract( { a_path = ([], "Float") }, [] )
- | TAbstract( { a_path = ([], "Bool") }, [] ) ->
- true
- | _ -> false
- let is_bool t =
- match follow t with
- | TAbstract ({ a_path = ([], "Bool") },[]) ->
- true
- | _ -> false
- let like_bool t =
- match follow t with
- | TAbstract ({ a_path = ([], "Bool") },[])
- | TAbstract ({ a_path = (["java";"lang"],"Boolean") },[])
- | TInst ({ cl_path = (["java";"lang"],"Boolean") },[]) ->
- true
- | _ -> false
- let is_int_float gen t =
- match follow (gen.greal_type t) with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TAbstract( { a_path = ([], "Int") }, [] )
- | TAbstract( { a_path = ([], "Float") }, [] ) ->
- true
- | (TAbstract _ as t) when like_float t && not (like_i64 t)-> true
- | _ -> false
- let parse_explicit_iface =
- let regex = Str.regexp "\\." in
- let parse_explicit_iface str =
- let split = Str.split regex str in
- let rec get_iface split pack =
- match split with
- | clname :: fn_name :: [] -> fn_name, (List.rev pack, clname)
- | pack_piece :: tl -> get_iface tl (pack_piece :: pack)
- | _ -> assert false
- in
- get_iface split []
- in parse_explicit_iface
- let is_string t =
- match follow t with
- | TInst( { cl_path = ([], "String") }, [] ) -> true
- | _ -> false
- let is_cl t = match follow t with
- | TInst({ cl_path = ["java";"lang"],"Class" },_)
- | TAbstract({ a_path = [], ("Class"|"Enum") },_) -> true
- | TAnon(a) when is_some (anon_class t) -> true
- | _ -> false
- (* ******************************************* *)
- (* JavaSpecificESynf *)
- (* ******************************************* *)
- (*
- Some Java-specific syntax filters that must run before ExpressionUnwrap
- dependencies:
- It must run before ExprUnwrap, as it may not return valid Expr/Statement expressions
- It must run before ClassInstance, as it will detect expressions that need unchanged TTypeExpr
- It must run after CastDetect, as it changes casts
- It must run after TryCatchWrapper, to change Std.is() calls inside there
- *)
- module JavaSpecificESynf =
- struct
- let name = "java_specific_e"
- let priority = solve_deps name [ DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter CastDetect.priority; DAfter TryCatchWrapper.priority ]
- let get_cl_from_t t =
- match follow t with
- | TInst(cl,_) -> cl
- | _ -> assert false
- let traverse gen runtime_cl =
- let basic = gen.gcon.basic in
- let float_cl = get_cl ( get_type gen (["java";"lang"], "Double")) in
- let i8_md = ( get_type gen (["java";"lang"], "Byte")) in
- let i16_md = ( get_type gen (["java";"lang"], "Short")) in
- let i64_md = ( get_type gen (["java";"lang"], "Long")) in
- let c16_md = ( get_type gen (["java";"lang"], "Character")) in
- let f_md = ( get_type gen (["java";"lang"], "Float")) in
- let bool_md = get_type gen (["java";"lang"], "Boolean") in
- let is_var = alloc_var "__is__" t_dynamic in
- let rec run e =
- match e.eexpr with
- (* Math changes *)
- | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NaN" }) ) ->
- mk_static_field_access_infer float_cl "NaN" e.epos []
- | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NEGATIVE_INFINITY" }) ) ->
- mk_static_field_access_infer float_cl "NEGATIVE_INFINITY" e.epos []
- | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "POSITIVE_INFINITY" }) ) ->
- mk_static_field_access_infer float_cl "POSITIVE_INFINITY" e.epos []
- | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isNaN"}) ) ->
- mk_static_field_access_infer float_cl "isNaN" e.epos []
- | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("ffloor" as f) }) ) } as fe), p)
- | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fceil" as f) }) ) } as fe), p) ->
- Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic (String.sub f 1 (String.length f - 1))) }, p) }
- | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fround") }) ) } as fe), p) ->
- Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic "rint") }, p) }
- | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "floor" }) ) }, _)
- | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "round" }) ) }, _)
- | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "ceil" }) ) }, _) ->
- mk_cast basic.tint (Type.map_expr run { e with etype = basic.tfloat })
- | TCall( ( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isFinite" }) ) } as efield ), [v]) ->
- { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "isFinite" efield.epos [], [run v] ) }
- (* end of math changes *)
- (* Std.is() *)
- | TCall(
- { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is" })) },
- [ obj; { eexpr = TTypeExpr(md) } ]
- ) ->
- let mk_is is_basic obj md =
- let obj = if is_basic then mk_cast t_dynamic obj else obj in
- { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [
- run obj;
- { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos }
- ] ) }
- in
- (match follow_module follow md with
- | TAbstractDecl({ a_path = ([], "Float") }) ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "isDouble" e.epos [],
- [ run obj ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TAbstractDecl{ a_path = ([], "Int") } ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "isInt" e.epos [],
- [ run obj ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TAbstractDecl{ a_path = ([], "Bool") } ->
- mk_is true obj bool_md
- | TAbstractDecl{ a_path = ([], "Single") } ->
- mk_is true obj f_md
- | TAbstractDecl{ a_path = (["java"], "Int8") } ->
- mk_is true obj i8_md
- | TAbstractDecl{ a_path = (["java"], "Int16") } ->
- mk_is true obj i16_md
- | TAbstractDecl{ a_path = (["java"], "Char16") } ->
- mk_is true obj c16_md
- | TAbstractDecl{ a_path = (["java"], "Int64") } ->
- mk_is true obj i64_md
- | TClassDecl{ cl_path = (["haxe"], "Int64") } ->
- mk_is true obj i64_md
- | TAbstractDecl{ a_path = ([], "Dynamic") }
- | TClassDecl{ cl_path = ([], "Dynamic") } ->
- (match obj.eexpr with
- | TLocal _ | TConst _ -> { e with eexpr = TConst(TBool true) }
- | _ -> { e with eexpr = TBlock([run obj; { e with eexpr = TConst(TBool true) }]) }
- )
- | _ ->
- mk_is false obj md
- )
- (* end Std.is() *)
- | _ -> Type.map_expr run e
- in
- run
- let configure gen (mapping_func:texpr->texpr) =
- let map e = Some(mapping_func e) in
- gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
- end;;
- (* ******************************************* *)
- (* JavaSpecificSynf *)
- (* ******************************************* *)
- (*
- Some Java-specific syntax filters that can run after ExprUnwrap
- dependencies:
- Runs after ExprUnwarp
- *)
- module JavaSpecificSynf =
- struct
- let name = "java_specific"
- let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DBefore IntDivisionSynf.priority ]
- let java_hash s =
- let h = ref Int32.zero in
- let thirtyone = Int32.of_int 31 in
- for i = 0 to String.length s - 1 do
- h := Int32.add (Int32.mul thirtyone !h) (Int32.of_int (int_of_char (String.unsafe_get s i)));
- done;
- !h
- let rec is_final_return_expr is_switch e =
- let is_final_return_expr = is_final_return_expr is_switch in
- match e.eexpr with
- | TReturn _
- | TThrow _ -> true
- (* this is hack to not use 'break' on switch cases *)
- | TLocal { v_name = "__fallback__" } when is_switch -> true
- | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> true
- | TParenthesis p | TMeta (_,p) -> is_final_return_expr p
- | TBlock bl -> is_final_return_block is_switch bl
- | TSwitch (_, el_e_l, edef) ->
- List.for_all (fun (_,e) -> is_final_return_expr e) el_e_l && Option.map_default is_final_return_expr false edef
- (* | TMatch (_, _, il_vl_e_l, edef) ->
- List.for_all (fun (_,_,e) -> is_final_return_expr e)il_vl_e_l && Option.map_default is_final_return_expr false edef *)
- | TIf (_,eif, Some eelse) ->
- is_final_return_expr eif && is_final_return_expr eelse
- | TFor (_,_,e) ->
- is_final_return_expr e
- | TWhile (_,e,_) ->
- is_final_return_expr e
- | TFunction tf ->
- is_final_return_expr tf.tf_expr
- | TTry (e, ve_l) ->
- is_final_return_expr e && List.for_all (fun (_,e) -> is_final_return_expr e) ve_l
- | _ -> false
- and is_final_return_block is_switch el =
- match el with
- | [] -> false
- | final :: [] -> is_final_return_expr is_switch final
- | hd :: tl -> is_final_return_block is_switch tl
- let is_null e = match e.eexpr with | TConst(TNull) -> true | _ -> false
- let rec is_equatable gen t =
- match follow t with
- | TInst(cl,_) ->
- if cl.cl_path = (["haxe";"lang"], "IEquatable") then
- true
- else
- List.exists (fun (cl,p) -> is_equatable gen (TInst(cl,p))) cl.cl_implements
- || (match cl.cl_super with | Some(cl,p) -> is_equatable gen (TInst(cl,p)) | None -> false)
- | _ -> false
- (*
- Changing string switch
- will take an expression like
- switch(str)
- {
- case "a":
- case "b":
- }
- and modify it to:
- {
- var execute_def = true;
- switch(str.hashCode())
- {
- case (hashcode of a):
- if (str == "a")
- {
- execute_def = false;
- ..code here
- } //else if (str == otherVariableWithSameHashCode) {
- ...
- }
- ...
- }
- if (execute_def)
- {
- ..default code
- }
- }
- this might actually be slower in some cases than a if/else approach, but it scales well and as a bonus,
- hashCode in java are cached, so we only have the performance hit once to cache it.
- *)
- let change_string_switch gen eswitch e1 ecases edefault =
- let basic = gen.gcon.basic in
- let is_final_ret = is_final_return_expr false eswitch in
- let has_default = is_some edefault in
- let block = ref [] in
- let local = match e1.eexpr with
- | TLocal _ -> e1
- | _ ->
- let var = mk_temp gen "svar" e1.etype in
- let added = { e1 with eexpr = TVar(var, Some(e1)); etype = basic.tvoid } in
- let local = mk_local var e1.epos in
- block := added :: !block;
- local
- in
- let execute_def_var = mk_temp gen "executeDef" gen.gcon.basic.tbool in
- let execute_def = mk_local execute_def_var e1.epos in
- 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
- let hash_cache = ref None in
- let local_hashcode = ref { local with
- eexpr = TCall({ local with
- eexpr = TField(local, FDynamic "hashCode");
- etype = TFun([], basic.tint);
- }, []);
- etype = basic.tint
- } in
- let get_hash_cache () =
- match !hash_cache with
- | Some c -> c
- | None ->
- let var = mk_temp gen "hash" basic.tint in
- let cond = !local_hashcode in
- block := { eexpr = TVar(var, Some cond); etype = basic.tvoid; epos = local.epos } :: !block;
- let local = mk_local var local.epos in
- local_hashcode := local;
- hash_cache := Some local;
- local
- in
- let has_case = ref false in
- (* first we need to reorder all cases so all collisions are close to each other *)
- let get_str e = match e.eexpr with | TConst(TString s) -> s | _ -> assert false in
- let has_conflict = ref false in
- let rec reorder_cases unordered ordered =
- match unordered with
- | [] -> ordered
- | (el, e) :: tl ->
- let current = Hashtbl.create 1 in
- List.iter (fun e ->
- let str = get_str e in
- let hash = java_hash str in
- Hashtbl.add current hash true
- ) el;
- let rec extract_fields cases found_cases ret_cases =
- match cases with
- | [] -> found_cases, ret_cases
- | (el, e) :: tl ->
- if List.exists (fun e -> Hashtbl.mem current (java_hash (get_str e)) ) el then begin
- has_conflict := true;
- List.iter (fun e -> Hashtbl.add current (java_hash (get_str e)) true) el;
- extract_fields tl ( (el, e) :: found_cases ) ret_cases
- end else
- extract_fields tl found_cases ( (el, e) :: ret_cases )
- in
- let found, remaining = extract_fields tl [] [] in
- let ret = if found <> [] then
- let ret = List.sort (fun (e1,_) (e2,_) -> compare (List.length e2) (List.length e1) ) ( (el, e) :: found ) in
- let rec loop ret acc =
- match ret with
- | (el, e) :: ( (_,_) :: _ as tl ) -> loop tl ( (true, el, e) :: acc )
- | (el, e) :: [] -> ( (false, el, e) :: acc )
- | _ -> assert false
- in
- List.rev (loop ret [])
- else
- (false, el, e) :: []
- in
- reorder_cases remaining (ordered @ ret)
- in
- let already_in_cases = Hashtbl.create 0 in
- let change_case (has_fallback, el, e) =
- let conds, el = List.fold_left (fun (conds,el) e ->
- has_case := true;
- match e.eexpr with
- | TConst(TString s) ->
- let hashed = java_hash s in
- let equals_test = {
- eexpr = TCall({ e with eexpr = TField(local, FDynamic "equals"); etype = TFun(["obj",false,t_dynamic],basic.tbool) }, [ e ]);
- etype = basic.tbool;
- epos = e.epos
- } in
- let hashed_expr = { eexpr = TConst(TInt hashed); etype = basic.tint; epos = e.epos } in
- let hashed_exprs = if !has_conflict then begin
- if Hashtbl.mem already_in_cases hashed then
- el
- else begin
- Hashtbl.add already_in_cases hashed true;
- hashed_expr :: el
- end
- end else hashed_expr :: el in
- let conds = match conds with
- | None -> equals_test
- | Some c ->
- (*
- if there is more than one case, we should test first if hash equals to the one specified.
- This way we can save a heavier string compare
- *)
- let equals_test = mk_paren {
- eexpr = TBinop(Ast.OpBoolAnd, { eexpr = TBinop(Ast.OpEq, get_hash_cache(), hashed_expr); etype = basic.tbool; epos = e.epos }, equals_test);
- etype = basic.tbool;
- epos = e.epos;
- } in
- { eexpr = TBinop(Ast.OpBoolOr, equals_test, c); etype = basic.tbool; epos = e1.epos }
- in
- Some conds, hashed_exprs
- | _ -> assert false
- ) (None,[]) el in
- let e = if has_default then Type.concat execute_def_set e else e in
- let e = if !has_conflict then Type.concat e { e with eexpr = TBreak; etype = basic.tvoid } else e in
- let e = {
- eexpr = TIf(get conds, e, None);
- etype = basic.tvoid;
- epos = e.epos
- } in
- let e = if has_fallback then { e with eexpr = TBlock([ e; mk_local (alloc_var "__fallback__" t_dynamic) e.epos]) } else e in
- (el, e)
- in
- let switch = { eswitch with
- eexpr = TSwitch(!local_hashcode, List.map change_case (reorder_cases ecases []), None);
- } in
- (if !has_case then begin
- (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);
- block := switch :: !block
- end);
- (match edefault with
- | None -> ()
- | Some edef when not !has_case ->
- block := edef :: !block
- | Some edef ->
- 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
- block := { edef with eexpr = TIf(execute_def, edef, eelse); etype = basic.tvoid } :: !block
- );
- { eswitch with eexpr = TBlock(List.rev !block) }
- let get_cl_from_t t =
- match follow t with
- | TInst(cl,_) -> cl
- | _ -> assert false
- let traverse gen runtime_cl =
- let basic = gen.gcon.basic in
- (* let tchar = mt_to_t_dyn ( get_type gen (["java"], "Char16") ) in *)
- (* let tbyte = mt_to_t_dyn ( get_type gen (["java"], "Int8") ) in *)
- (* let tshort = mt_to_t_dyn ( get_type gen (["java"], "Int16") ) in *)
- (* let tsingle = mt_to_t_dyn ( get_type gen ([], "Single") ) in *)
- let string_ext = get_cl ( get_type gen (["haxe";"lang"], "StringExt")) in
- let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false in
- let rec run e =
- match e.eexpr with
- (* for new NativeArray<T> issues *)
- | TNew(({ cl_path = (["java"], "NativeArray") } as cl), [t], el) when is_type_param t ->
- mk_cast (TInst(cl,[t])) (mk_cast t_dynamic ({ e with eexpr = TNew(cl, [t_empty], List.map run el) }))
- (* Std.int() *)
- | TCall(
- { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" })) },
- [obj]
- ) ->
- run (mk_cast basic.tint obj)
- (* end Std.int() *)
- | TField( ef, FInstance({ cl_path = ([], "String") }, _, { cf_name = "length" }) ) ->
- { e with eexpr = TCall(Type.map_expr run e, []) }
- | TField( ef, field ) when field_name field = "length" && is_string ef.etype ->
- { e with eexpr = TCall(Type.map_expr run e, []) }
- | TCall( ( { eexpr = TField(ef, field) } as efield ), args ) when is_string ef.etype && String.get (field_name field) 0 = '_' ->
- let field = field_name field in
- { e with eexpr = TCall({ efield with eexpr = TField(run ef, FDynamic (String.sub field 1 ( (String.length field) - 1)) )}, List.map run args) }
- | TCall( ( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, _, field )) } as efield ), args ) ->
- let field = field.cf_name in
- (match field with
- | "charAt" | "charCodeAt" | "split" | "indexOf"
- | "lastIndexOf" | "substring" | "substr" ->
- { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) }
- | _ ->
- { e with eexpr = TCall(run efield, List.map run args) }
- )
- (* | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("toString") })) }, [] ) ->
- run ef *)
- (* | TCast(expr, m) when is_boxed_type e.etype -> *)
- (* (* let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with *) *)
- (* run { e with etype = unboxed_type gen e.etype tbyte tshort tchar tsingle } *)
- | TCast(expr, _) when is_bool e.etype ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "toBool" expr.epos [],
- [ run expr ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TCast(expr, _) when is_int_float gen e.etype && not (is_int_float gen expr.etype) ->
- let needs_cast = match gen.gfollow#run_f e.etype with
- | TInst _ -> false
- | _ -> true
- in
- let fun_name = if like_int e.etype then "toInt" else "toDouble" in
- let ret = {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl fun_name expr.epos [],
- [ run expr ]
- );
- etype = if fun_name = "toDouble" then basic.tfloat else basic.tint;
- epos = expr.epos
- } in
- if needs_cast then mk_cast e.etype ret else ret
- (*| TCast(expr, c) when is_int_float gen e.etype ->
- (* cases when float x = (float) (java.lang.Double val); *)
- (* FIXME: this fix is broken since it will fail on cases where float x = (float) (java.lang.Float val) or similar. FIX THIS *)
- let need_second_cast = match gen.gfollow#run_f e.etype with
- | TInst _ -> false
- | _ -> true
- in
- if need_second_cast then { e with eexpr = TCast(mk_cast (follow e.etype) (run expr), c) } else Type.map_expr run e*)
- | TBinop( (Ast.OpAssignOp OpAdd as op), e1, e2)
- | TBinop( (Ast.OpAdd as op), e1, e2) when is_string e.etype || is_string e1.etype || is_string e2.etype ->
- let is_assign = match op with Ast.OpAssignOp _ -> true | _ -> false in
- 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
- let check_cast e = match gen.greal_type e.etype with
- | TDynamic _
- | TAbstract({ a_path = ([], "Float") }, [])
- | TAbstract({ a_path = ([], "Single") }, []) ->
- mk_to_string e
- | _ -> run e
- in
- { e with eexpr = TBinop(op, (if is_assign then run e1 else check_cast e1), check_cast e2) }
- | TCast(expr, _) when is_string e.etype ->
- { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) }
- | TSwitch(cond, ecases, edefault) when is_string cond.etype ->
- (*let change_string_switch gen eswitch e1 ecases edefault =*)
- change_string_switch gen e (run cond) (List.map (fun (el,e) -> (el, run e)) ecases) (Option.map run edefault)
- | TBinop( (Ast.OpNotEq as op), e1, e2)
- | 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) ->
- let static = mk_static_field_access_infer (runtime_cl) "valEq" e1.epos [] in
- let eret = { eexpr = TCall(static, [run e1; run e2]); etype = gen.gcon.basic.tbool; epos=e.epos } in
- if op = Ast.OpNotEq then { eret with eexpr = TUnop(Ast.Not, Ast.Prefix, eret) } else eret
- | TBinop( (Ast.OpNotEq | Ast.OpEq as op), e1, e2) when is_cl e1.etype && is_cl e2.etype ->
- { e with eexpr = TBinop(op, mk_cast t_empty (run e1), mk_cast t_empty (run e2)) }
- | _ -> Type.map_expr run e
- in
- run
- let configure gen (mapping_func:texpr->texpr) =
- (if java_hash "Testing string hashCode implementation from haXe" <> (Int32.of_int 545883604) then assert false);
- let map e = Some(mapping_func e) in
- gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
- end;;
- (* ******************************************* *)
- (* handle @:throws *)
- (* ******************************************* *)
- let rec is_checked_exc cl =
- match cl.cl_path with
- | ["java";"lang"],"RuntimeException" ->
- false
- | ["java";"lang"],"Throwable" ->
- true
- | _ -> match cl.cl_super with
- | None -> false
- | Some(c,_) -> is_checked_exc c
- let rec cls_any_super cl supers =
- PMap.mem cl.cl_path supers || match cl.cl_super with
- | None -> false
- | Some(c,_) -> cls_any_super c supers
- let rec handle_throws gen cf =
- List.iter (handle_throws gen) cf.cf_overloads;
- match cf.cf_expr with
- | Some ({ eexpr = TFunction(tf) } as e) ->
- let rec collect_throws acc = function
- | (Meta.Throws, [Ast.EConst (Ast.String path), _],_) :: meta -> (try
- collect_throws (get_cl ( get_type gen (parse_path path)) :: acc) meta
- with | Not_found | TypeNotFound _ ->
- collect_throws acc meta)
- | [] ->
- acc
- | _ :: meta ->
- collect_throws acc meta
- in
- let cf_throws = collect_throws [] cf.cf_meta in
- let throws = ref (List.fold_left (fun map cl ->
- PMap.add cl.cl_path cl map
- ) PMap.empty cf_throws) in
- let rec iter e = match e.eexpr with
- | TTry(etry,ecatches) ->
- let old = !throws in
- let needs_check_block = ref true in
- List.iter (fun (v,e) ->
- Type.iter iter e;
- match follow (run_follow gen v.v_type) with
- | TInst({ cl_path = ["java";"lang"],"Throwable" },_)
- | TDynamic _ ->
- needs_check_block := false
- | TInst(c,_) when is_checked_exc c ->
- throws := PMap.add c.cl_path c !throws
- | _ ->()
- ) ecatches;
- if !needs_check_block then Type.iter iter etry;
- throws := old
- | TField(e, (FInstance(_,_,f) | FStatic(_,f) | FClosure(_,f))) ->
- let tdefs = collect_throws [] f.cf_meta in
- if tdefs <> [] && not (List.for_all (fun c -> cls_any_super c !throws) tdefs) then
- raise Exit;
- Type.iter iter e
- | TThrow e -> (match follow (run_follow gen e.etype) with
- | TInst(c,_) when is_checked_exc c && not (cls_any_super c !throws) ->
- raise Exit
- | _ -> iter e)
- | _ -> Type.iter iter e
- in
- (try
- Type.iter iter e
- with | Exit -> (* needs typed exception to be caught *)
- let throwable = get_cl (get_type gen (["java";"lang"],"Throwable")) in
- let catch_var = alloc_var "typedException" (TInst(throwable,[])) in
- let rethrow = mk_local catch_var e.epos in
- let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in
- let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], t_dynamic)) rethrow.epos in
- let wrapped = { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]) }; } in
- let map_throws cl =
- let var = alloc_var "typedException" (TInst(cl,List.map (fun _ -> t_dynamic) cl.cl_params)) in
- var, { tf.tf_expr with eexpr = TThrow (mk_local var e.epos) }
- in
- cf.cf_expr <- Some { e with
- eexpr = TFunction({ tf with
- tf_expr = mk_block { tf.tf_expr with eexpr = TTry(tf.tf_expr, List.map (map_throws) cf_throws @ [catch_var, wrapped]) }
- })
- })
- | _ -> ()
- 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 *)
- let default_package = "java"
- let strict_mode = ref false (* strict mode is so we can check for unexpected information *)
- (* reserved java words *)
- let reserved = let res = Hashtbl.create 120 in
- List.iter (fun lst -> Hashtbl.add res lst ("_" ^ lst)) ["abstract"; "assert"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class";
- "const"; "continue"; "default"; "do"; "double"; "else"; "enum"; "extends"; "final";
- "false"; "finally"; "float"; "for"; "goto"; "if"; "implements"; "import"; "instanceof"; "int";
- "interface"; "long"; "native"; "new"; "null"; "package"; "private"; "protected"; "public"; "return"; "short";
- "static"; "strictfp"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; "transient"; "true"; "try";
- "void"; "volatile"; "while"; ];
- res
- let dynamic_anon = TAnon( { a_fields = PMap.empty; a_status = ref Closed } )
- let rec get_class_modifiers meta cl_type cl_access cl_modifiers =
- match meta with
- | [] -> cl_type,cl_access,cl_modifiers
- (*| (Meta.Struct,[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers*)
- | (Meta.Protected,[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers
- | (Meta.Internal,[],_) :: meta -> get_class_modifiers meta cl_type "" cl_modifiers
- (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers)
- | (Meta.Static,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("static" :: cl_modifiers) TODO: support those types *)
- | (Meta.Final,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("final" :: cl_modifiers)
- | _ :: meta -> get_class_modifiers meta cl_type cl_access cl_modifiers
- let rec get_fun_modifiers meta access modifiers =
- match meta with
- | [] -> access,modifiers
- | (Meta.Protected,[],_) :: meta -> get_fun_modifiers meta "protected" modifiers
- | (Meta.Internal,[],_) :: meta -> get_fun_modifiers meta "" modifiers
- | (Meta.ReadOnly,[],_) :: meta -> get_fun_modifiers meta access ("final" :: modifiers)
- (*| (Meta.Unsafe,[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)*)
- | (Meta.Volatile,[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers)
- | (Meta.Transient,[],_) :: meta -> get_fun_modifiers meta access ("transient" :: modifiers)
- | (Meta.Native,[],_) :: meta -> get_fun_modifiers meta access ("native" :: modifiers)
- | _ :: meta -> get_fun_modifiers meta access modifiers
- (* this was the way I found to pass the generator context to be accessible across all functions here *)
- (* so 'configure' is almost 'top-level' and will have all functions needed to make this work *)
- let configure gen =
- let native_arr_cl = get_cl ( get_type gen (["java"], "NativeArray") ) in
- gen.gclasses.nativearray <- (fun t -> TInst(native_arr_cl,[t]));
- gen.gclasses.nativearray_type <- (function TInst(_,[t]) -> t | _ -> assert false);
- gen.gclasses.nativearray_len <- (fun e p -> mk_field_access gen e "length" p);
- let basic = gen.gcon.basic in
- let fn_cl = get_cl (get_type gen (["haxe";"lang"],"Function")) in
- let runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in
- let nulltdef = get_tdef (get_type gen ([],"Null")) in
- (*let string_ref = get_cl ( get_type gen (["haxe";"lang"], "StringRefl")) in*)
- let ti64 = match ( get_type gen (["java"], "Int64") ) with | TAbstractDecl a -> TAbstract(a,[]) | _ -> assert false in
- let has_tdynamic params =
- List.exists (fun e -> match run_follow gen e with | TDynamic _ -> true | _ -> false) params
- in
- (*
- The type parameters always need to be changed to their boxed counterparts
- *)
- let change_param_type md params =
- match md with
- | TClassDecl( { cl_path = (["java"], "NativeArray") } ) -> params
- | TAbstractDecl { a_path=[],("Class" | "Enum") } | TClassDecl { cl_path = (["java";"lang"],("Class"|"Enum")) } ->
- List.map (fun _ -> t_dynamic) params
- | _ ->
- match params with
- | [] -> []
- | _ ->
- if has_tdynamic params then List.map (fun _ -> t_dynamic) params else
- List.map (fun t ->
- let f_t = gen.gfollow#run_f t in
- match f_t with
- | TAbstract ({ a_path = ([], "Bool") },[])
- | TAbstract ({ a_path = ([],"Float") },[])
- | TInst ({ cl_path = ["haxe"],"Int32" },[])
- | TInst ({ cl_path = ["haxe"],"Int64" },[])
- | TAbstract ({ a_path = ([],"Int") },[])
- | TType ({ t_path = ["java"], "Int64" },[])
- | TAbstract ({ a_path = ["java"], "Int64" },[])
- | TType ({ t_path = ["java"],"Int8" },[])
- | TAbstract ({ a_path = ["java"],"Int8" },[])
- | TType ({ t_path = ["java"],"Int16" },[])
- | TAbstract ({ a_path = ["java"],"Int16" },[])
- | TType ({ t_path = ["java"],"Char16" },[])
- | TAbstract ({ a_path = ["java"],"Char16" },[])
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) ->
- TType(nulltdef, [f_t])
- (*| TType ({ t_path = [], "Null"*)
- | TInst (cl, ((_ :: _) as p)) when cl.cl_path <> (["java"],"NativeArray") ->
- TInst(cl, List.map (fun _ -> t_dynamic) p)
- | TEnum (e, ((_ :: _) as p)) ->
- TEnum(e, List.map (fun _ -> t_dynamic) p)
- | _ -> t
- ) params
- in
- let change_clname name =
- String.map (function | '$' -> '.' | c -> c) name
- in
- let change_id name = try Hashtbl.find reserved name with | Not_found -> name in
- let rec change_ns ns = match ns with
- | [] -> ["haxe"; "root"]
- | _ -> List.map change_id ns
- in
- let change_field = change_id in
- let write_id w name = write w (change_id name) in
- let write_field w name = write w (change_field name) in
- gen.gfollow#add ~name:"follow_basic" (fun t -> match t with
- | TAbstract ({ a_path = ([], "Bool") },[])
- | TAbstract ({ a_path = ([], "Void") },[])
- | TAbstract ({ a_path = ([],"Float") },[])
- | TAbstract ({ a_path = ([],"Int") },[])
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TType ({ t_path = ["java"], "Int64" },[])
- | TAbstract ({ a_path = ["java"], "Int64" },[])
- | TType ({ t_path = ["java"],"Int8" },[])
- | TAbstract ({ a_path = ["java"],"Int8" },[])
- | TType ({ t_path = ["java"],"Int16" },[])
- | TAbstract ({ a_path = ["java"],"Int16" },[])
- | TType ({ t_path = ["java"],"Char16" },[])
- | TAbstract ({ a_path = ["java"],"Char16" },[])
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) ->
- Some t
- | TType (({ t_path = [],"Null" } as tdef),[t2]) ->
- Some (TType(tdef,[gen.gfollow#run_f t2]))
- | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
- Some (gen.gfollow#run_f ( Abstract.get_underlying_type a pl) )
- | TAbstract( { a_path = ([], "EnumValue") }, _ )
- | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic
- | _ -> None);
- let change_path path = (change_ns (fst path), change_clname (snd path)) in
- let path_s path meta = try
- match Meta.get Meta.JavaCanonical meta with
- | (Meta.JavaCanonical, [EConst(String pack), _; EConst(String name), _], _) ->
- if pack = "" then
- name
- else
- pack ^ "." ^ name
- | _ -> raise Not_found
- with Not_found -> match path with
- | (ns,clname) -> path_s (change_ns ns, change_clname clname)
- in
- let cl_cl = get_cl (get_type gen (["java";"lang"],"Class")) in
- let rec real_type t =
- let t = gen.gfollow#run_f t in
- match t with
- | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
- real_type (Abstract.get_underlying_type a pl)
- | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64
- | TAbstract( { a_path = ([], "Class") }, p )
- | TAbstract( { a_path = ([], "Enum") }, p )
- | TInst( { cl_path = ([], "Class") }, p )
- | TInst( { cl_path = ([], "Enum") }, p ) -> TInst(cl_cl,[t_dynamic])
- | TEnum(e,params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
- | TInst(c,params) when Meta.has Meta.Enum c.cl_meta ->
- TInst(c, List.map (fun _ -> t_dynamic) params)
- | TInst _ -> t
- | TType({ t_path = ([], "Null") }, [t]) when is_java_basic_type (gen.gfollow#run_f t) -> t_dynamic
- | TType({ t_path = ([], "Null") }, [t]) ->
- (match follow t with
- | TInst( { cl_kind = KTypeParameter _ }, []) ->
- t_dynamic
- (* real_type t *)
- | _ -> real_type t
- )
- | TType _ | TAbstract _ -> t
- | TAnon (anon) -> (match !(anon.a_status) with
- | Statics _ | EnumStatics _ | AbstractStatics _ -> t
- | _ -> t_dynamic)
- | TFun _ -> TInst(fn_cl,[])
- | _ -> t_dynamic
- in
- let scope = ref PMap.empty in
- let imports = ref [] in
- let clear_scope () =
- scope := PMap.empty;
- imports := [];
- in
- let add_scope name =
- scope := PMap.add name () !scope
- in
- let add_import pos path meta =
- let name = snd path in
- let rec loop = function
- | (pack, n) :: _ when name = n ->
- if path <> (pack,n) then
- gen.gcon.error ("This expression cannot be generated because " ^ path_s path meta ^ " is shadowed by the current scope and ") pos
- | _ :: tl ->
- loop tl
- | [] ->
- (* add import *)
- imports := path :: !imports
- in
- loop !imports
- in
- let path_s_import pos path meta = match path with
- | [], name when PMap.mem name !scope ->
- gen.gcon.error ("This expression cannot be generated because " ^ name ^ " is shadowed by the current scope") pos;
- name
- | pack1 :: _, name when PMap.mem pack1 !scope -> (* exists in scope *)
- add_import pos path meta;
- (* check if name exists in scope *)
- if PMap.mem name !scope then
- gen.gcon.error ("This expression cannot be generated because " ^ pack1 ^ " and " ^ name ^ " are both shadowed by the current scope") pos;
- name
- | _ -> path_s path meta
- in
- let is_dynamic t = match real_type t with
- | TMono _ | TDynamic _
- | TInst({ cl_kind = KTypeParameter _ }, _) -> true
- | TAnon anon ->
- (match !(anon.a_status) with
- | EnumStatics _ | Statics _ | AbstractStatics _ -> false
- | _ -> true
- )
- | _ -> false
- in
- let rec t_s pos t =
- match real_type t with
- (* basic types *)
- | TAbstract ({ a_path = ([], "Bool") },[]) -> "boolean"
- | TAbstract ({ a_path = ([], "Void") },[]) ->
- path_s_import pos (["java";"lang"], "Object") []
- | TAbstract ({ a_path = ([],"Float") },[]) -> "double"
- | TAbstract ({ a_path = ([],"Int") },[]) -> "int"
- | TType ({ t_path = ["java"], "Int64" },[])
- | TAbstract ({ a_path = ["java"], "Int64" },[]) -> "long"
- | TType ({ t_path = ["java"],"Int8" },[])
- | TAbstract ({ a_path = ["java"],"Int8" },[]) -> "byte"
- | TType ({ t_path = ["java"],"Int16" },[])
- | TAbstract ({ a_path = ["java"],"Int16" },[]) -> "short"
- | TType ({ t_path = ["java"],"Char16" },[])
- | TAbstract ({ a_path = ["java"],"Char16" },[]) -> "char"
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) -> "float"
- | TInst ({ cl_path = ["haxe"],"Int32" },[])
- | TAbstract ({ a_path = ["haxe"],"Int32" },[]) -> "int"
- | TInst ({ cl_path = ["haxe"],"Int64" },[])
- | TAbstract ({ a_path = ["haxe"],"Int64" },[]) -> "long"
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- let rec check_t_s t =
- match real_type t with
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- (check_t_s param) ^ "[]"
- | _ -> t_s pos (run_follow gen t)
- in
- (check_t_s param) ^ "[]"
- (* end of basic types *)
- | TInst ({ cl_kind = KTypeParameter _; cl_path=p }, []) -> snd p
- | TAbstract ({ a_path = [], "Dynamic" },[]) ->
- path_s_import pos (["java";"lang"], "Object") []
- | TMono r -> (match !r with | None -> "java.lang.Object" | Some t -> t_s pos (run_follow gen t))
- | TInst ({ cl_path = [], "String" }, []) ->
- path_s_import pos (["java";"lang"], "String") []
- | TAbstract ({ a_path = [], "Class" }, [p]) | TAbstract ({ a_path = [], "Enum" }, [p])
- | TInst ({ cl_path = [], "Class" }, [p]) | TInst ({ cl_path = [], "Enum" }, [p]) ->
- path_param_s pos (TClassDecl cl_cl) (["java";"lang"], "Class") [p] []
- | TAbstract ({ a_path = [], "Class" }, _) | TAbstract ({ a_path = [], "Enum" }, _)
- | TInst ({ cl_path = [], "Class" }, _) | TInst ({ cl_path = [], "Enum" }, _) ->
- path_s_import pos (["java";"lang"], "Class") []
- | TEnum ({e_path = p; e_meta = meta}, _) ->
- path_s_import pos p meta
- | TInst (({cl_path = p; cl_meta = meta} as cl), _) when Meta.has Meta.Enum cl.cl_meta ->
- path_s_import pos p meta
- | TInst (({cl_path = p; cl_meta = meta} as cl), params) -> (path_param_s pos (TClassDecl cl) p params meta)
- | TType (({t_path = p; t_meta = meta} as t), params) -> (path_param_s pos (TTypeDecl t) p params meta)
- | TAnon (anon) ->
- (match !(anon.a_status) with
- | Statics _ | EnumStatics _ | AbstractStatics _ ->
- path_s_import pos (["java";"lang"], "Class") []
- | _ ->
- path_s_import pos (["java";"lang"], "Object") [])
- | TDynamic _ ->
- path_s_import pos (["java";"lang"], "Object") []
- (* No Lazy type nor Function type made. That's because function types will be at this point be converted into other types *)
- | _ -> 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) ^ " ]"
- and param_t_s pos t =
- match run_follow gen t with
- | TAbstract ({ a_path = ([], "Bool") },[]) ->
- path_s_import pos (["java";"lang"], "Boolean") []
- | TAbstract ({ a_path = ([],"Float") },[]) ->
- path_s_import pos (["java";"lang"], "Double") []
- | TAbstract ({ a_path = ([],"Int") },[]) ->
- path_s_import pos (["java";"lang"], "Integer") []
- | TType ({ t_path = ["java"], "Int64" },[])
- | TAbstract ({ a_path = ["java"], "Int64" },[]) ->
- path_s_import pos (["java";"lang"], "Long") []
- | TInst ({ cl_path = ["haxe"],"Int64" },[])
- | TAbstract ({ a_path = ["haxe"],"Int64" },[]) ->
- path_s_import pos (["java";"lang"], "Long") []
- | TInst ({ cl_path = ["haxe"],"Int32" },[])
- | TAbstract ({ a_path = ["haxe"],"Int32" },[]) ->
- path_s_import pos (["java";"lang"], "Integer") []
- | TType ({ t_path = ["java"],"Int8" },[])
- | TAbstract ({ a_path = ["java"],"Int8" },[]) ->
- path_s_import pos (["java";"lang"], "Byte") []
- | TType ({ t_path = ["java"],"Int16" },[])
- | TAbstract ({ a_path = ["java"],"Int16" },[]) ->
- path_s_import pos (["java";"lang"], "Short") []
- | TType ({ t_path = ["java"],"Char16" },[])
- | TAbstract ({ a_path = ["java"],"Char16" },[]) ->
- path_s_import pos (["java";"lang"], "Character") []
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) ->
- path_s_import pos (["java";"lang"], "Float") []
- | TDynamic _ -> "?"
- | TInst (cl, params) -> t_s pos (TInst(cl, change_param_type (TClassDecl cl) params))
- | TType (cl, params) -> t_s pos (TType(cl, change_param_type (TTypeDecl cl) params))
- | TEnum (e, params) -> t_s pos (TEnum(e, change_param_type (TEnumDecl e) params))
- | _ -> t_s pos t
- and path_param_s pos md path params meta =
- match params with
- | [] -> path_s_import pos path meta
- | _ when has_tdynamic (change_param_type md params) -> path_s_import pos path meta
- | _ -> 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)))
- in
- let rett_s pos t =
- match t with
- | TAbstract ({ a_path = ([], "Void") },[]) -> "void"
- | _ -> t_s pos t
- in
- let high_surrogate c = (c lsr 10) + 0xD7C0 in
- let low_surrogate c = (c land 0x3FF) lor 0xDC00 in
- let escape ichar b =
- match ichar with
- | 92 (* \ *) -> Buffer.add_string b "\\\\"
- | 39 (* ' *) -> Buffer.add_string b "\\\'"
- | 34 -> Buffer.add_string b "\\\""
- | 13 (* \r *) -> Buffer.add_string b "\\r"
- | 10 (* \n *) -> Buffer.add_string b "\\n"
- | 9 (* \t *) -> Buffer.add_string b "\\t"
- | c when c < 32 || (c >= 127 && c <= 0xFFFF) -> Buffer.add_string b (Printf.sprintf "\\u%.4x" c)
- | c when c > 0xFFFF -> Buffer.add_string b (Printf.sprintf "\\u%.4x\\u%.4x" (high_surrogate c) (low_surrogate c))
- | c -> Buffer.add_char b (Char.chr c)
- in
- let escape s =
- let b = Buffer.create 0 in
- (try
- UTF8.validate s;
- UTF8.iter (fun c -> escape (UChar.code c) b) s
- with
- UTF8.Malformed_code ->
- String.iter (fun c -> escape (Char.code c) b) s
- );
- Buffer.contents b
- in
- let has_semicolon e =
- match e.eexpr with
- | TLocal { v_name = "__fallback__" }
- | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt _) } ] ) -> false
- | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, _ ) -> false
- | TBlock _ | TFor _ | TSwitch _ | TTry _ | TIf _ -> false
- | TWhile (_,_,flag) when flag = Ast.NormalWhile -> false
- | _ -> true
- in
- let in_value = ref false in
- let rec md_s pos md =
- let md = follow_module (gen.gfollow#run_f) md in
- match md with
- | TClassDecl (cl) ->
- t_s pos (TInst(cl,[]))
- | TEnumDecl (e) ->
- t_s pos (TEnum(e,[]))
- | TTypeDecl t ->
- t_s pos (TType(t, []))
- | TAbstractDecl a ->
- t_s pos (TAbstract(a, []))
- in
- (*
- it seems that Java doesn't like when you create a new array with the type parameter defined
- so we'll just ignore all type parameters, and hope for the best!
- *)
- let rec transform_nativearray_t t = match real_type t with
- | TInst( ({ cl_path = (["java"], "NativeArray") } as narr), [t]) ->
- TInst(narr, [transform_nativearray_t t])
- | TInst(cl, params) -> TInst(cl, List.map (fun _ -> t_dynamic) params)
- | TEnum(e, params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
- | TType(t, params) -> TType(t, List.map (fun _ -> t_dynamic) params)
- | _ -> t
- in
- let rec extract_tparams params el =
- match el with
- | ({ eexpr = TLocal({ v_name = "$type_param" }) } as tp) :: tl ->
- extract_tparams (tp.etype :: params) tl
- | _ -> (params, el)
- in
- let line_directive =
- if Common.defined gen.gcon Define.RealPosition then
- fun w p -> ()
- else fun w p ->
- let cur_line = Lexer.get_error_line p in
- let file = Common.get_full_path p.pfile in
- print w "//line %d \"%s\"" cur_line (Ast.s_escape file); newline w
- in
- let extract_statements expr =
- let ret = ref [] in
- let rec loop expr = match expr.eexpr with
- | TCall ({ eexpr = TLocal {
- v_name = "__is__" | "__typeof__" | "__array__"
- } }, el) ->
- List.iter loop el
- | TNew ({ cl_path = (["java"], "NativeArray") }, params, [ size ]) ->
- ()
- | TUnop (Ast.Increment, _, _)
- | TUnop (Ast.Decrement, _, _)
- | TBinop (Ast.OpAssign, _, _)
- | TBinop (Ast.OpAssignOp _, _, _)
- | TLocal { v_name = "__fallback__" }
- | TLocal { v_name = "__sbreak__" } ->
- ret := expr :: !ret
- | TConst _
- | TLocal _
- | TArray _
- | TBinop _
- | TField _
- | TEnumParameter _
- | TTypeExpr _
- | TObjectDecl _
- | TArrayDecl _
- | TCast _
- | TMeta _
- | TParenthesis _
- | TUnop _ ->
- Type.iter loop expr
- | TFunction _ -> () (* do not extract parameters from inside of it *)
- | _ ->
- ret := expr :: !ret
- in
- loop expr;
- (* [expr] *)
- List.rev !ret
- in
- let expr_s w e =
- in_value := false;
- let rec expr_s w e =
- let was_in_value = !in_value in
- in_value := true;
- match e.eexpr with
- | TConst c ->
- (match c with
- | TInt i32 ->
- print w "%ld" i32;
- (match real_type e.etype with
- | TType( { t_path = (["java"], "Int64") }, [] ) -> write w "L";
- | _ -> ()
- )
- | TFloat s ->
- write w s;
- (* fix for Int notation, which only fit in a Float *)
- (if not (String.contains s '.' || String.contains s 'e' || String.contains s 'E') then write w ".0");
- (match real_type e.etype with
- | TType( { t_path = ([], "Single") }, [] ) -> write w "f"
- | _ -> ()
- )
- | TString s -> print w "\"%s\"" (escape s)
- | TBool b -> write w (if b then "true" else "false")
- | TNull ->
- (match real_type e.etype with
- | TAbstract( { a_path = (["java"], "Int64") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> write w "0L"
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TAbstract ({ a_path = ([], "Int") },[]) -> expr_s w ({ e with eexpr = TConst(TInt Int32.zero) })
- | TAbstract ({ a_path = ([], "Float") },[]) -> expr_s w ({ e with eexpr = TConst(TFloat "0.0") })
- | TAbstract ({ a_path = ([], "Bool") },[]) -> write w "false"
- | TAbstract _ when like_int e.etype ->
- expr_s w (mk_cast e.etype { e with eexpr = TConst(TInt Int32.zero) })
- | TAbstract _ when like_float e.etype ->
- expr_s w (mk_cast e.etype { e with eexpr = TConst(TFloat "0.0") } )
- | t -> write w ("null") )
- | TThis -> write w "this"
- | TSuper -> write w "super")
- | TLocal { v_name = "__fallback__" } -> ()
- | TLocal { v_name = "__sbreak__" } -> write w "break"
- | TLocal { v_name = "__undefined__" } ->
- write w (t_s e.epos (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_params)));
- write w ".undefined";
- | TLocal var ->
- write_id w var.v_name
- | TField(_, FEnum(en,ef)) ->
- let s = ef.ef_name in
- print w "%s." (path_s_import e.epos en.e_path en.e_meta); write_field w s
- | TArray (e1, e2) ->
- expr_s w e1; write w "["; expr_s w e2; write w "]"
- | TBinop ((Ast.OpAssign as op), e1, e2)
- | TBinop ((Ast.OpAssignOp _ as op), e1, e2) ->
- expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2
- | TBinop (op, e1, e2) ->
- write w "( ";
- expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2;
- write w " )"
- | TField (e, FStatic(_, cf)) when Meta.has Meta.Native cf.cf_meta ->
- let rec loop meta = match meta with
- | (Meta.Native, [EConst (String s), _],_) :: _ ->
- expr_s w e; write w "."; write_field w s
- | _ :: tl -> loop tl
- | [] -> expr_s w e; write w "."; write_field w (cf.cf_name)
- in
- loop cf.cf_meta
- | TField (e, s) ->
- expr_s w e; write w "."; write_field w (field_name s)
- | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int32") }) ->
- write w (path_s_import e.epos (["haxe"], "Int32") [])
- | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int64") }) ->
- write w (path_s_import e.epos (["haxe"], "Int64") [])
- | TTypeExpr mt -> write w (md_s e.epos mt)
- | TParenthesis e ->
- write w "("; expr_s w e; write w ")"
- | TMeta (_,e) ->
- expr_s w e
- | TCall ({ eexpr = TLocal { v_name = "__array__" } }, el)
- | TCall ({ eexpr = TField(_, FStatic({ cl_path = (["java"],"NativeArray") }, { cf_name = "make" })) }, el)
- | TArrayDecl el when t_has_type_param e.etype ->
- let _, el = extract_tparams [] el in
- print w "( (%s) (new %s " (t_s e.epos e.etype) (t_s e.epos (replace_type_param e.etype));
- write w "{";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w "}) )"
- | TCall ({ eexpr = TLocal { v_name = "__array__" } }, el)
- | TCall ({ eexpr = TField(_, FStatic({ cl_path = (["java"],"NativeArray") }, { cf_name = "make" })) }, el)
- | TArrayDecl el ->
- let _, el = extract_tparams [] el in
- print w "new %s" (param_t_s e.epos (transform_nativearray_t e.etype));
- let is_double = match follow e.etype with
- | TInst(_,[ t ]) -> if like_float t && not (like_int t) then Some t else None
- | _ -> None
- in
- write w "{";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- (* this is a hack so we are able to convert ints to boxed Double / Float when needed *)
- let e = if is_some is_double then mk_cast (get is_double) e else e in
- expr_s w e;
- acc + 1
- ) 0 el);
- write w "}"
- | TCall( ( { eexpr = TField(_, FStatic({ cl_path = ([], "String") }, { cf_name = "fromCharCode" })) } ), [cc] ) ->
- write w "Character.toString((char) ";
- expr_s w cc;
- write w ")"
- | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
- write w "( ";
- expr_s w expr;
- write w " instanceof ";
- write w (md_s e.epos md);
- write w " )"
- | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) ->
- write w s
- | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, { eexpr = TConst(TString(s)) } :: tl ) ->
- Codegen.interpolate_code gen.gcon s tl (write w) (expr_s w) e.epos
- | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) ->
- write w "synchronized(";
- let rec loop eobj = match eobj.eexpr with
- | TTypeExpr md ->
- expr_s w eobj;
- write w ".class"
- | TMeta(_,e) | TParenthesis(e) ->
- loop e
- | _ ->
- expr_s w eobj
- in
- loop eobj;
- write w ")";
- (match eblock.eexpr with
- | TBlock(_ :: _) ->
- expr_s w eblock
- | _ ->
- begin_block w;
- expr_s w eblock;
- if has_semicolon eblock then write w ";";
- end_block w;
- )
- | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "break label%ld" v
- | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "label%ld:" v
- | TCall ({ eexpr = TLocal( { v_name = "__typeof__" } ) }, [ { eexpr = TTypeExpr md } as expr ] ) ->
- expr_s w expr;
- write w ".class"
- | TCall (e, el) ->
- let params, el = extract_tparams [] el in
- expr_s w e;
- (*(match params with
- | [] -> ()
- | params ->
- let md = match e.eexpr with
- | TField(ef, _) -> t_to_md (run_follow gen ef.etype)
- | _ -> assert false
- in
- write w "<";
- ignore (List.fold_left (fun acc t ->
- (if acc <> 0 then write w ", ");
- write w (param_t_s (change_param_type md t));
- acc + 1
- ) 0 params);
- write w ">"
- );*)
- write w "(";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w ")"
- | TNew (({ cl_path = (["java"], "NativeArray") } as cl), params, [ size ]) ->
- let rec check_t_s t times =
- match real_type t with
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- (check_t_s param (times+1))
- | _ ->
- print w "new %s[" (t_s e.epos (transform_nativearray_t t));
- expr_s w size;
- print w "]";
- let rec loop i =
- if i <= 0 then () else (write w "[]"; loop (i-1))
- in
- loop (times - 1)
- in
- check_t_s (TInst(cl, params)) 0
- | TNew ({ cl_path = ([], "String") } as cl, [], el) ->
- write w "new ";
- write w (t_s e.epos (TInst(cl, [])));
- write w "(";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w ")"
- | TNew ({ cl_kind = KTypeParameter _ } as cl, params, el) ->
- 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)
- | TNew (cl, params, el) ->
- write w "new ";
- write w (path_param_s e.epos (TClassDecl cl) cl.cl_path params cl.cl_meta);
- write w "(";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w ")"
- | TUnop ((Ast.Increment as op), flag, e)
- | TUnop ((Ast.Decrement as op), flag, e) ->
- (match flag with
- | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " " ); expr_s w e
- | Ast.Postfix -> expr_s w e; write w (Ast.s_unop op))
- | TUnop (op, flag, e) ->
- (match flag with
- | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " (" ); expr_s w e; write w ") "
- | Ast.Postfix -> write w "("; expr_s w e; write w (") " ^ Ast.s_unop op))
- | TVar (var, eopt) ->
- print w "%s " (t_s e.epos var.v_type);
- write_id w var.v_name;
- (match eopt with
- | None ->
- write w " = ";
- expr_s w (null var.v_type e.epos)
- | Some e ->
- write w " = ";
- expr_s w e
- )
- | TBlock [e] when was_in_value ->
- expr_s w e
- | TBlock el ->
- begin_block w;
- List.iter (fun e ->
- List.iter (fun e ->
- in_value := false;
- line_directive w e.epos;
- expr_s w e;
- if has_semicolon e then write w ";";
- newline w;
- ) (extract_statements e)
- ) el;
- end_block w
- | TIf (econd, e1, Some(eelse)) when was_in_value ->
- write w "( ";
- expr_s w (mk_paren econd);
- write w " ? ";
- expr_s w (mk_paren e1);
- write w " : ";
- expr_s w (mk_paren eelse);
- write w " )";
- | TIf (econd, e1, eelse) ->
- write w "if ";
- expr_s w (mk_paren econd);
- write w " ";
- in_value := false;
- expr_s w (mk_block e1);
- (match eelse with
- | None -> ()
- | Some e ->
- write w "else";
- in_value := false;
- expr_s w (mk_block e)
- )
- | TWhile (econd, eblock, flag) ->
- (match flag with
- | Ast.NormalWhile ->
- write w "while ";
- expr_s w (mk_paren econd);
- write w "";
- in_value := false;
- expr_s w (mk_block eblock)
- | Ast.DoWhile ->
- write w "do ";
- in_value := false;
- expr_s w (mk_block eblock);
- write w "while ";
- in_value := true;
- expr_s w (mk_paren econd);
- )
- | TSwitch (econd, ele_l, default) ->
- write w "switch ";
- expr_s w (mk_paren econd);
- begin_block w;
- List.iter (fun (el, e) ->
- List.iter (fun e ->
- write w "case ";
- in_value := true;
- (match e.eexpr with
- | TField(_,FEnum(e,ef)) ->
- write w ef.ef_name
- | _ ->
- expr_s w e);
- write w ":";
- newline w;
- ) el;
- in_value := false;
- expr_s w (mk_block e);
- newline w;
- newline w
- ) ele_l;
- if is_some default then begin
- write w "default:";
- newline w;
- in_value := false;
- expr_s w (get default);
- newline w;
- end;
- end_block w
- | TTry (tryexpr, ve_l) ->
- write w "try ";
- in_value := false;
- expr_s w (mk_block tryexpr);
- let pos = e.epos in
- List.iter (fun (var, e) ->
- print w "catch (%s %s)" (t_s pos var.v_type) (var.v_name);
- in_value := false;
- expr_s w (mk_block e);
- newline w
- ) ve_l
- | TReturn eopt ->
- write w "return ";
- if is_some eopt then expr_s w (get eopt)
- | TBreak -> write w "break"
- | TContinue -> write w "continue"
- | TThrow e ->
- write w "throw ";
- expr_s w e
- | TCast (e1,md_t) ->
- ((*match gen.gfollow#run_f e.etype with
- | TType({ t_path = ([], "UInt") }, []) ->
- write w "( unchecked ((uint) ";
- expr_s w e1;
- write w ") )"
- | _ ->*)
- (* FIXME I'm ignoring module type *)
- print w "((%s) (" (t_s e.epos e.etype);
- expr_s w e1;
- write w ") )"
- )
- | TFor (_,_,content) ->
- write w "[ for not supported ";
- expr_s w content;
- write w " ]";
- if !strict_mode then assert false
- | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
- | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
- | TEnumParameter _ -> write w "[ enum parameter not supported ]"; if !strict_mode then assert false
- in
- expr_s w e
- in
- let rec gen_fpart_attrib w = function
- | EConst( Ident i ), _ ->
- write w i
- | EField( ef, f ), _ ->
- gen_fpart_attrib w ef;
- write w ".";
- write w f
- | _, p ->
- gen.gcon.error "Invalid expression inside @:meta metadata" p
- in
- let rec gen_spart w = function
- | EConst c, p -> (match c with
- | Int s | Float s | Ident s ->
- write w s
- | String s ->
- write w "\"";
- write w (escape s);
- write w "\""
- | _ -> gen.gcon.error "Invalid expression inside @:meta metadata" p)
- | EField( ef, f ), _ ->
- gen_spart w ef;
- write w ".";
- write w f
- | EBinop( Ast.OpAssign, (EConst (Ident s), _), e2 ), _ ->
- write w s;
- write w " = ";
- gen_spart w e2
- | EArrayDecl( el ), _ ->
- write w "{";
- let fst = ref true in
- List.iter (fun e ->
- if !fst then fst := false else write w ", ";
- gen_spart w e
- ) el;
- write w "}"
- | ECall(fpart,args), _ ->
- gen_fpart_attrib w fpart;
- write w "(";
- let fst = ref true in
- List.iter (fun e ->
- if !fst then fst := false else write w ", ";
- gen_spart w e
- ) args;
- write w ")"
- | _, p ->
- gen.gcon.error "Invalid expression inside @:meta metadata" p
- in
- let gen_annotations w ?(add_newline=true) metadata =
- List.iter (function
- | Meta.Meta, [meta], _ ->
- write w "@";
- gen_spart w meta;
- if add_newline then newline w else write w " ";
- | _ -> ()
- ) metadata
- in
- let argt_s p t =
- let w = new_source_writer () in
- let rec run t =
- match t with
- | TType (tdef,p) ->
- gen_annotations w ~add_newline:false tdef.t_meta;
- run (follow_once t)
- | TMono r ->
- (match !r with
- | Some t -> run t
- | _ -> () (* avoid infinite loop / should be the same in this context *))
- | TLazy f ->
- run (!f())
- | _ -> ()
- in
- run t;
- let ret = t_s p t in
- let c = contents w in
- if c <> "" then
- c ^ " " ^ ret
- else
- ret
- in
- let get_string_params cl_params =
- match cl_params with
- | [] ->
- ("","")
- | _ ->
- 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
- let params_extends = List.fold_left (fun acc (name, t) ->
- match run_follow gen t with
- | TInst (cl, p) ->
- (match cl.cl_implements with
- | [] -> acc
- | _ -> acc) (* TODO
- | _ -> (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 ) *)
- | _ -> 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 *)
- ) [] cl_params in
- (params, String.concat " " params_extends)
- in
- let write_parts w parts =
- let parts = List.filter (fun s -> s <> "") parts in
- write w (String.concat " " parts)
- in
- let rec gen_class_field w ?(is_overload=false) is_static cl is_final cf =
- let is_interface = cl.cl_interface in
- let name, is_new, is_explicit_iface = match cf.cf_name with
- | "new" -> snd cl.cl_path, true, false
- | name when String.contains name '.' ->
- let fn_name, path = parse_explicit_iface name in
- (path_s path cl.cl_meta) ^ "." ^ fn_name, false, true
- | name -> name, false, false
- in
- (match cf.cf_kind with
- | Var _
- | Method (MethDynamic) when not (Type.is_extern_field cf) ->
- (if is_overload || List.exists (fun cf -> cf.cf_expr <> None) cf.cf_overloads then
- gen.gcon.error "Only normal (non-dynamic) methods can be overloaded" cf.cf_pos);
- if not is_interface then begin
- let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in
- 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)]);
- (match cf.cf_expr with
- | Some e ->
- write w " = ";
- expr_s w e;
- write w ";"
- | None -> write w ";"
- )
- end (* TODO see how (get,set) variable handle when they are interfaces *)
- | Method _ when Type.is_extern_field cf || (match cl.cl_kind, cf.cf_expr with | KAbstractImpl _, None -> true | _ -> false) ->
- List.iter (fun cf -> if cl.cl_interface || cf.cf_expr <> None then
- gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
- ) cf.cf_overloads
- | Var _ | Method MethDynamic -> ()
- | Method mkind ->
- List.iter (fun cf ->
- if cl.cl_interface || cf.cf_expr <> None then
- gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
- ) cf.cf_overloads;
- let is_virtual = is_new || (not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false) in
- let is_override = match cf.cf_name with
- | "equals" when not is_static ->
- (match cf.cf_type with
- | TFun([_,_,t], ret) ->
- (match (real_type t, real_type ret) with
- | TDynamic _, TAbstract ({ a_path = ([], "Bool") },[])
- | TAnon _, TAbstract ({ a_path = ([], "Bool") },[]) -> true
- | _ -> List.memq cf cl.cl_overrides
- )
- | _ -> List.memq cf cl.cl_overrides)
- | "toString" when not is_static ->
- (match cf.cf_type with
- | TFun([], ret) ->
- (match real_type ret with
- | TInst( { cl_path = ([], "String") }, []) -> true
- | _ -> gen.gcon.error "A toString() function should return a String!" cf.cf_pos; false
- )
- | _ -> List.memq cf cl.cl_overrides
- )
- | "hashCode" when not is_static ->
- (match cf.cf_type with
- | TFun([], ret) ->
- (match real_type ret with
- | TAbstract ({ a_path = ([], "Int") },[]) ->
- true
- | _ -> gen.gcon.error "A hashCode() function should return an Int!" cf.cf_pos; false
- )
- | _ -> List.memq cf cl.cl_overrides
- )
- | _ -> List.memq cf cl.cl_overrides
- in
- let visibility = if is_interface then "" else "public" in
- let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in
- let visibility, is_virtual = if is_explicit_iface then "",false else visibility, is_virtual in
- 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
- 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
- let params = List.map snd cl.cl_params in
- let ret_type, args = match follow cf_type, follow cf.cf_type with
- | TFun (strbtl, t), TFun(rargs, _) ->
- (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)
- | _ -> assert false
- in
- (if is_override && not is_interface then write w "@Override ");
- gen_annotations w cf.cf_meta;
- (* public static void funcName *)
- let params, _ = get_string_params cf.cf_params in
- 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)]);
- (* <T>(string arg1, object arg2) with T : object *)
- (match cf.cf_expr with
- | Some { eexpr = TFunction tf } ->
- 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))
- | _ ->
- 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))
- );
- if is_interface || List.mem "native" modifiers then
- write w ";"
- else begin
- let rec loop meta =
- match meta with
- | [] ->
- let expr = match cf.cf_expr with
- | None -> mk (TBlock([])) t_dynamic Ast.null_pos
- | Some s ->
- match s.eexpr with
- | TFunction tf ->
- mk_block (tf.tf_expr)
- | _ -> assert false (* FIXME *)
- in
- (if is_new then begin
- (*let rec get_super_call el =
- match el with
- | ( { eexpr = TCall( { eexpr = TConst(TSuper) }, _) } as call) :: rest ->
- Some call, rest
- | ( { eexpr = TBlock(bl) } as block ) :: rest ->
- let ret, mapped = get_super_call bl in
- ret, ( { block with eexpr = TBlock(mapped) } :: rest )
- | _ ->
- None, el
- in*)
- expr_s w expr
- end else begin
- expr_s w expr;
- end)
- | (Meta.Throws, [Ast.EConst (Ast.String t), _], _) :: tl ->
- print w " throws %s" t;
- loop tl
- | (Meta.FunctionCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
- begin_block w;
- write w contents;
- end_block w
- | _ :: tl -> loop tl
- in
- loop cf.cf_meta
- end);
- newline w;
- newline w
- in
- let gen_class w cl =
- let cf_filters = [ handle_throws ] in
- List.iter (fun f -> List.iter (f gen) cl.cl_ordered_fields) cf_filters;
- List.iter (fun f -> List.iter (f gen) cl.cl_ordered_statics) cf_filters;
- let should_close = match change_ns (fst cl.cl_path) with
- | [] -> false
- | ns ->
- print w "package %s;" (String.concat "." (change_ns ns));
- newline w;
- newline w;
- false
- in
- let rec loop_meta meta acc =
- match meta with
- | (Meta.SuppressWarnings, [Ast.EConst (Ast.String w),_],_) :: meta -> loop_meta meta (w :: acc)
- | _ :: meta -> loop_meta meta acc
- | _ -> acc
- in
- let suppress_warnings = loop_meta cl.cl_meta [ "rawtypes"; "unchecked" ] in
- write w "import haxe.root.*;";
- newline w;
- let w_header = w in
- let w = new_source_writer () in
- clear_scope();
- (* add all haxe.root.* to imports *)
- List.iter (function
- | TClassDecl { cl_path = ([],c) } ->
- imports := ([],c) :: !imports
- | TEnumDecl { e_path = ([],c) } ->
- imports := ([],c) :: !imports
- | TAbstractDecl { a_path = ([],c) } ->
- imports := ([],c) :: !imports
- | _ -> ()
- ) gen.gcon.types;
- newline w;
- write w "@SuppressWarnings(value={";
- let first = ref true in
- List.iter (fun s ->
- (if !first then first := false else write w ", ");
- print w "\"%s\"" (escape s)
- ) suppress_warnings;
- write w "})";
- newline w;
- gen_annotations w cl.cl_meta;
- let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
- let is_final = Meta.has Meta.Final cl.cl_meta in
- write_parts w (access :: modifiers @ [clt; (change_clname (snd cl.cl_path))]);
- (* type parameters *)
- let params, _ = get_string_params cl.cl_params in
- let cl_p_to_string (c,p) =
- let p = List.map (fun t -> match follow t with
- | TMono _ | TDynamic _ -> t_empty
- | _ -> t) p
- in
- path_param_s cl.cl_pos (TClassDecl c) c.cl_path p c.cl_meta
- in
- print w "%s" params;
- (if is_some cl.cl_super then print w " extends %s" (cl_p_to_string (get cl.cl_super)));
- (match cl.cl_implements with
- | [] -> ()
- | _ -> print w " %s %s" (if cl.cl_interface then "extends" else "implements") (String.concat ", " (List.map cl_p_to_string cl.cl_implements))
- );
- (* class head ok: *)
- (* public class Test<A> : X, Y, Z where A : Y *)
- begin_block w;
- (* our constructor is expected to be a normal "new" function *
- if !strict_mode && is_some cl.cl_constructor then assert false;*)
- let rec loop cl =
- List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_fields;
- List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_statics;
- match cl.cl_super with
- | Some(c,_) -> loop c
- | None -> ()
- in
- loop cl;
- let rec loop meta =
- match meta with
- | [] -> ()
- | (Meta.ClassCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
- write w contents
- | _ :: tl -> loop tl
- in
- loop cl.cl_meta;
- (match gen.gcon.main_class with
- | Some path when path = cl.cl_path ->
- write w "public static void main(String[] args)";
- begin_block w;
- (try
- let t = Hashtbl.find gen.gtypes ([], "Sys") in
- match t with
- | TClassDecl(cl) when PMap.mem "_args" cl.cl_statics ->
- write w "Sys._args = args;"; newline w
- | _ -> ()
- with | Not_found -> ()
- );
- write w "main();";
- end_block w;
- newline w
- | _ -> ()
- );
- (match cl.cl_init with
- | None -> ()
- | Some init ->
- write w "static";
- expr_s w (mk_block init);
- newline w
- );
- (if is_some cl.cl_constructor then gen_class_field w false cl is_final (get cl.cl_constructor));
- (if not cl.cl_interface then List.iter (gen_class_field w true cl is_final) cl.cl_ordered_statics);
- List.iter (gen_class_field w false cl is_final) cl.cl_ordered_fields;
- end_block w;
- if should_close then end_block w;
- (* add imports *)
- List.iter (function
- | ["haxe";"root"], _ | [], _ -> ()
- | path ->
- write w_header "import ";
- write w_header (path_s path []);
- write w_header ";\n"
- ) !imports;
- add_writer w w_header
- in
- let gen_enum w e =
- let should_close = match change_ns (fst e.e_path) with
- | [] -> false
- | ns ->
- print w "package %s;" (String.concat "." (change_ns ns));
- newline w;
- newline w;
- false
- in
- gen_annotations w e.e_meta;
- print w "public enum %s" (change_clname (snd e.e_path));
- begin_block w;
- write w (String.concat ", " (List.map (change_id) e.e_names));
- end_block w;
- if should_close then end_block w
- in
- let module_type_gen w md_tp =
- match md_tp with
- | TClassDecl cl ->
- if not cl.cl_extern then begin
- gen_class w cl;
- newline w;
- newline w
- end;
- (not cl.cl_extern)
- | TEnumDecl e ->
- if not e.e_extern then begin
- gen_enum w e;
- newline w;
- newline w
- end;
- (not e.e_extern)
- | TTypeDecl e ->
- false
- | TAbstractDecl a ->
- false
- in
- let module_gen w md =
- module_type_gen w md
- in
- (* generate source code *)
- init_ctx gen;
- Hashtbl.add gen.gspecial_vars "__label__" true;
- Hashtbl.add gen.gspecial_vars "__goto__" true;
- Hashtbl.add gen.gspecial_vars "__is__" true;
- Hashtbl.add gen.gspecial_vars "__typeof__" true;
- Hashtbl.add gen.gspecial_vars "__java__" true;
- Hashtbl.add gen.gspecial_vars "__lock__" true;
- Hashtbl.add gen.gspecial_vars "__array__" true;
- gen.greal_type <- real_type;
- gen.greal_type_param <- change_param_type;
- SetHXGen.run_filter gen SetHXGen.default_hxgen_func;
- (* before running the filters, follow all possible types *)
- (* this is needed so our module transformations don't break some core features *)
- (* like multitype selection *)
- let run_follow_gen = run_follow gen in
- 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
- let super_map (cl,tl) = (cl, List.map run_follow_gen tl) in
- List.iter (function
- | TClassDecl cl ->
- let all_fields = (Option.map_default (fun cf -> [cf]) [] cl.cl_constructor) @ cl.cl_ordered_fields @ cl.cl_ordered_statics in
- List.iter (fun cf ->
- cf.cf_type <- run_follow_gen cf.cf_type;
- cf.cf_expr <- Option.map type_map cf.cf_expr
- ) all_fields;
- cl.cl_dynamic <- Option.map run_follow_gen cl.cl_dynamic;
- cl.cl_array_access <- Option.map run_follow_gen cl.cl_array_access;
- cl.cl_init <- Option.map type_map cl.cl_init;
- cl.cl_super <- Option.map super_map cl.cl_super;
- cl.cl_implements <- List.map super_map cl.cl_implements
- | _ -> ()
- ) gen.gcon.types;
- let closure_t = ClosuresToClass.DoubleAndDynamicClosureImpl.get_ctx gen 6 in
- (*let closure_t = ClosuresToClass.create gen 10 float_cl
- (fun l -> l)
- (fun l -> l)
- (fun args -> args)
- (fun args -> [])
- in
- ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (fun e _ _ -> e));
- StubClosureImpl.configure gen (StubClosureImpl.default_implementation gen float_cl 10 (fun e _ _ -> e));*)
- FixOverrides.configure gen;
- Normalize.configure gen ~metas:(Hashtbl.create 0);
- AbstractImplementationFix.configure gen;
- IteratorsInterface.configure gen (fun e -> e);
- ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) ));
- let enum_base = (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) in
- let param_enum_base = (get_cl (get_type gen (["haxe";"lang"],"ParamEnum")) ) in
- EnumToClass.configure gen (None) false true enum_base param_enum_base false false;
- InterfaceVarsDeleteModf.configure gen;
- let dynamic_object = (get_cl (get_type gen (["haxe";"lang"],"DynamicObject")) ) in
- let object_iface = get_cl (get_type gen (["haxe";"lang"],"IHxObject")) in
- (*fixme: THIS IS A HACK. take this off *)
- let empty_e = match (get_type gen (["haxe";"lang"], "EmptyObject")) with | TEnumDecl e -> e | _ -> assert false in
- (*OverloadingCtor.set_new_create_empty gen ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;});*)
- let empty_expr = { eexpr = (TTypeExpr (TEnumDecl empty_e)); etype = (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics empty_e) }); epos = null_pos } in
- let empty_ef =
- try
- PMap.find "EMPTY" empty_e.e_constrs
- with Not_found -> gen.gcon.error "Required enum field EMPTY was not found" empty_e.e_pos; assert false
- in
- 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;
- let rcf_static_find = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "findHash" Ast.null_pos [] in
- (*let rcf_static_lookup = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "lookupHash" Ast.null_pos [] in*)
- let get_specialized_postfix t = match t with
- | TAbstract({a_path = [],"Float"}, _) -> "Float"
- | TInst({cl_path = [],"String"},_) -> "String"
- | TAnon _ | TDynamic _ -> "Dynamic"
- | _ -> print_endline (debug_type t); assert false
- in
- 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
- 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
- let can_be_float t = like_float (real_type t) in
- let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe =
- let is_float = can_be_float (if is_none may_set then main_expr.etype else (get may_set).etype) in
- let fn_name = if is_some may_set then "setField" else "getField" in
- let fn_name = if is_float then fn_name ^ "_f" else fn_name in
- let pos = field_expr.epos in
- let is_unsafe = { eexpr = TConst(TBool is_unsafe); etype = basic.tbool; epos = pos } in
- let should_cast = match main_expr.etype with | TAbstract({ a_path = ([], "Float") }, []) -> false | _ -> true in
- let infer = mk_static_field_access_infer runtime_cl fn_name field_expr.epos [] in
- let first_args =
- [ field_expr; { eexpr = TConst(TString field); etype = basic.tstring; epos = pos } ]
- @ if is_some may_hash then [ { eexpr = TConst(TInt (get may_hash)); etype = basic.tint; epos = pos } ] else []
- in
- let args = first_args @ match is_float, may_set with
- | true, Some(set) ->
- [ if should_cast then mk_cast basic.tfloat set else set ]
- | false, Some(set) ->
- [ set ]
- | _ ->
- [ is_unsafe ]
- in
- let call = { main_expr with eexpr = TCall(infer,args) } in
- let call = if is_float && should_cast then mk_cast main_expr.etype call else call in
- call
- in
- let rcf_on_call_field ecall field_expr field may_hash args =
- let infer = mk_static_field_access_infer runtime_cl "callField" field_expr.epos [] in
- let hash_arg = match may_hash with
- | None -> []
- | Some h -> [ { eexpr = TConst(TInt h); etype = basic.tint; epos = field_expr.epos } ]
- in
- let arr_call = if args <> [] then
- { eexpr = TArrayDecl args; etype = basic.tarray t_dynamic; epos = ecall.epos }
- else
- null (basic.tarray t_dynamic) ecall.epos
- in
- let call_args =
- [field_expr; { field_expr with eexpr = TConst(TString field); etype = basic.tstring } ]
- @ hash_arg
- @ [ arr_call ]
- in
- mk_cast ecall.etype { ecall with eexpr = TCall(infer, call_args); etype = t_dynamic }
- in
- let rcf_ctx =
- ReflectionCFs.new_ctx
- gen
- closure_t
- object_iface
- false
- rcf_on_getset_field
- rcf_on_call_field
- (fun hash hash_array length -> { hash with eexpr = TCall(rcf_static_find, [hash; hash_array; length]); etype=basic.tint })
- (fun hash -> hash)
- (fun hash_array length pos value ->
- { hash_array with
- eexpr = TBinop(OpAssign,
- hash_array,
- mk (TCall(rcf_static_insert value.etype, [hash_array; length; pos; value])) hash_array.etype hash_array.epos)
- })
- (fun hash_array length pos ->
- let t = gen.gclasses.nativearray_type hash_array.etype in
- { hash_array with eexpr = TCall(rcf_static_remove t, [hash_array; length; pos]); etype = gen.gcon.basic.tvoid }
- )
- false
- in
- ReflectionCFs.UniversalBaseClass.default_config gen (get_cl (get_type gen (["haxe";"lang"],"HxObject")) ) object_iface dynamic_object;
- ReflectionCFs.configure_dynamic_field_access rcf_ctx false;
- (* let closure_func = ReflectionCFs.implement_closure_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"],"Closure")) ) in *)
- let closure_cl = get_cl (get_type gen (["haxe";"lang"],"Closure")) in
- let closure_func = ReflectionCFs.get_closure_func rcf_ctx closure_cl in
- ReflectionCFs.implement_varargs_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"], "VarArgsBase")) );
- let slow_invoke = mk_static_field_access_infer (runtime_cl) "slowCallField" Ast.null_pos [] in
- ReflectionCFs.configure rcf_ctx ~slow_invoke:(fun ethis efield eargs -> {
- eexpr = TCall(slow_invoke, [ethis; efield; eargs]);
- etype = t_dynamic;
- epos = ethis.epos;
- } ) object_iface;
- let objdecl_fn = ReflectionCFs.implement_dynamic_object_ctor rcf_ctx dynamic_object in
- ObjectDeclMap.configure gen (ObjectDeclMap.traverse gen objdecl_fn);
- InitFunction.configure gen true true;
- TArrayTransform.configure gen (TArrayTransform.default_implementation gen (
- fun e _ ->
- match e.eexpr with
- | TArray ({ eexpr = TLocal { v_extra = Some( _ :: _, _) } }, _) -> (* captured transformation *)
- false
- | TArray(e1, e2) ->
- ( match run_follow gen (follow e1.etype) with
- | TInst({ cl_path = (["java"], "NativeArray") }, _) -> false
- | _ -> true )
- | _ -> assert false
- ) "__get" "__set" );
- let field_is_dynamic t field =
- match field_access_esp gen (gen.greal_type t) field with
- | FClassField (cl,p,_,_,_,t,_) ->
- let p = change_param_type (TClassDecl cl) p in
- is_dynamic (apply_params cl.cl_params p t)
- | FEnumField _ -> false
- | _ -> true
- in
- let is_type_param e = match follow e with
- | TInst( { cl_kind = KTypeParameter _ },[]) -> true
- | _ -> false
- in
- let is_dynamic_expr e =
- is_dynamic e.etype || match e.eexpr with
- | TField(tf, f) ->
- field_is_dynamic tf.etype f
- | _ ->
- false
- in
- let may_nullable t = match gen.gfollow#run_f t with
- | TType({ t_path = ([], "Null") }, [t]) ->
- (match follow t with
- | TInst({ cl_path = ([], "String") }, [])
- | TAbstract ({ a_path = ([], "Float") },[])
- | TInst({ cl_path = (["haxe"], "Int32")}, [] )
- | TInst({ cl_path = (["haxe"], "Int64")}, [] )
- | TAbstract ({ a_path = ([], "Int") },[])
- | TAbstract ({ a_path = ([], "Bool") },[]) -> Some t
- | t when is_java_basic_type t -> Some t
- | _ -> None )
- | _ -> None
- in
- let is_double t = like_float t && not (like_int t) in
- let is_int t = like_int t in
- DynamicOperators.configure gen
- (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with
- | TBinop (Ast.OpEq, e1, e2) ->
- is_dynamic e1.etype || is_dynamic e2.etype || is_type_param e1.etype || is_type_param e2.etype
- | TBinop (Ast.OpAdd, e1, e2)
- | TBinop (Ast.OpNotEq, e1, e2) -> is_dynamic e1.etype || is_dynamic e2.etype || is_type_param e1.etype || is_type_param e2.etype
- | TBinop (Ast.OpLt, e1, e2)
- | TBinop (Ast.OpLte, e1, e2)
- | TBinop (Ast.OpGte, e1, e2)
- | 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
- | TBinop (_, e1, e2) -> is_dynamic e.etype || is_dynamic_expr e1 || is_dynamic_expr e2
- | TUnop (_, _, e1) ->
- is_dynamic_expr e1
- | _ -> false)
- (fun e1 e2 ->
- let is_null e = match e.eexpr with | TConst(TNull) | TLocal({ v_name = "__undefined__" }) -> true | _ -> false in
- match e1.eexpr, e2.eexpr with
- | TConst c1, TConst c2 when is_null e1 || is_null e2 ->
- { e1 with eexpr = TConst(TBool (c1 = c2)); etype = basic.tbool }
- | _ when is_null e1 || is_null e2 && not (is_java_basic_type e1.etype || is_java_basic_type e2.etype) ->
- { e1 with eexpr = TBinop(Ast.OpEq, e1, e2); etype = basic.tbool }
- | _ ->
- let is_ref = match follow e1.etype, follow e2.etype with
- | TDynamic _, _
- | _, TDynamic _
- | TAbstract ({ a_path = ([], "Float") },[]) , _
- | TInst( { cl_path = (["haxe"], "Int32") }, [] ), _
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ), _
- | TAbstract ({ a_path = ([], "Int") },[]) , _
- | TAbstract ({ a_path = ([], "Bool") },[]) , _
- | _, TAbstract ({ a_path = ([], "Float") },[])
- | _, TAbstract ({ a_path = ([], "Int") },[])
- | _, TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | _, TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | _, TAbstract ({ a_path = ([], "Bool") },[])
- | TInst( { cl_kind = KTypeParameter _ }, [] ), _
- | _, TInst( { cl_kind = KTypeParameter _ }, [] ) -> false
- | _, _ -> true
- in
- let static = mk_static_field_access_infer (runtime_cl) (if is_ref then "refEq" else "eq") e1.epos [] in
- { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tbool; epos=e1.epos }
- )
- (fun e e1 e2 ->
- match may_nullable e1.etype, may_nullable e2.etype with
- | Some t1, Some t2 ->
- let t1, t2 = if is_string t1 || is_string t2 then
- basic.tstring, basic.tstring
- else if is_double t1 || is_double t2 then
- basic.tfloat, basic.tfloat
- else if is_int t1 || is_int t2 then
- basic.tint, basic.tint
- else t1, t2 in
- { eexpr = TBinop(Ast.OpAdd, mk_cast t1 e1, mk_cast t2 e2); etype = e.etype; epos = e1.epos }
- | _ ->
- let static = mk_static_field_access_infer (runtime_cl) "plus" e1.epos [] in
- mk_cast e.etype { eexpr = TCall(static, [e1; e2]); etype = t_dynamic; epos=e1.epos })
- (fun e1 e2 ->
- if is_string e1.etype then begin
- { e1 with eexpr = TCall(mk_field_access gen e1 "compareTo" e1.epos, [ e2 ]); etype = gen.gcon.basic.tint }
- end else begin
- let static = mk_static_field_access_infer (runtime_cl) "compare" e1.epos [] in
- { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tint; epos=e1.epos }
- end));
- FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func);
- let base_exception = get_cl (get_type gen (["java"; "lang"], "Throwable")) in
- let base_exception_t = TInst(base_exception, []) in
- let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in
- let hx_exception_t = TInst(hx_exception, []) in
- let rec is_exception t =
- match follow t with
- | TInst(cl,_) ->
- if cl == base_exception then
- true
- else
- (match cl.cl_super with | None -> false | Some (cl,arg) -> is_exception (TInst(cl,arg)))
- | _ -> false
- in
- TryCatchWrapper.configure gen
- (
- TryCatchWrapper.traverse gen
- (fun t -> not (is_exception (real_type t)))
- (fun throwexpr expr ->
- let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], hx_exception_t)) expr.epos in
- { throwexpr with eexpr = TThrow { expr with eexpr = TCall(wrap_static, [expr]); etype = hx_exception_t }; etype = gen.gcon.basic.tvoid }
- )
- (fun v_to_unwrap pos ->
- let local = mk_cast hx_exception_t { eexpr = TLocal(v_to_unwrap); etype = v_to_unwrap.v_type; epos = pos } in
- mk_field_access gen local "obj" pos
- )
- (fun rethrow ->
- let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], hx_exception_t)) rethrow.epos in
- { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]); etype = hx_exception_t }; }
- )
- (base_exception_t)
- (hx_exception_t)
- (fun v e ->
- let exc_cl = get_cl (get_type gen (["haxe";"lang"],"Exceptions")) in
- let exc_field = mk_static_field_access_infer exc_cl "setException" e.epos [] in
- let esetstack = { eexpr = TCall(exc_field,[mk_local v e.epos]); etype = gen.gcon.basic.tvoid; epos = e.epos } in
- Type.concat esetstack e;
- )
- );
- let get_typeof e =
- { e with eexpr = TCall( { eexpr = TLocal( alloc_var "__typeof__" t_dynamic ); etype = t_dynamic; epos = e.epos }, [e] ) }
- in
- ClassInstance.configure gen (ClassInstance.traverse gen (fun e mt -> get_typeof e));
- (*let v = alloc_var "$type_param" t_dynamic in*)
- TypeParams.configure gen (fun ecall efield params elist ->
- { ecall with eexpr = TCall(efield, elist) }
- );
- CastDetect.configure gen (CastDetect.default_implementation gen ~native_string_cast:false (Some (TEnum(empty_e, []))) false);
- (*FollowAll.configure gen;*)
- SwitchToIf.configure gen (SwitchToIf.traverse gen (fun e ->
- match e.eexpr with
- | TSwitch(cond, cases, def) ->
- (match gen.gfollow#run_f cond.etype with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TAbstract ({ a_path = ([], "Int") },[])
- | TInst({ cl_path = ([], "String") },[]) ->
- (List.exists (fun (c,_) ->
- List.exists (fun expr -> match expr.eexpr with | TConst _ -> false | _ -> true ) c
- ) cases)
- | _ -> true
- )
- | _ -> assert false
- ) true );
- 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 }));
- UnnecessaryCastsRemoval.configure gen;
- IntDivisionSynf.configure gen (IntDivisionSynf.default_implementation gen true);
- UnreachableCodeEliminationSynf.configure gen (UnreachableCodeEliminationSynf.traverse gen false true true true);
- ArrayDeclSynf.configure gen (ArrayDeclSynf.default_implementation gen native_arr_cl);
- let goto_special = alloc_var "__goto__" t_dynamic in
- let label_special = alloc_var "__label__" t_dynamic in
- SwitchBreakSynf.configure gen (SwitchBreakSynf.traverse gen
- (fun e_loop n api ->
- { 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] ) };
- )
- (fun e_break n api ->
- { eexpr = TCall( mk_local goto_special e_break.epos, [ mk_int gen n e_break.epos ] ); etype = t_dynamic; epos = e_break.epos }
- )
- );
- DefaultArguments.configure gen (DefaultArguments.traverse gen);
- InterfaceMetas.configure gen;
- JavaSpecificSynf.configure gen (JavaSpecificSynf.traverse gen runtime_cl);
- JavaSpecificESynf.configure gen (JavaSpecificESynf.traverse gen runtime_cl);
- (* add native String as a String superclass *)
- let str_cl = match gen.gcon.basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in
- str_cl.cl_super <- Some (get_cl (get_type gen (["haxe";"lang"], "NativeString")), []);
- let mkdir dir = if not (Sys.file_exists dir) then Unix.mkdir dir 0o755 in
- mkdir gen.gcon.file;
- mkdir (gen.gcon.file ^ "/src");
- let out_files = ref [] in
- (* add resources array *)
- let res = ref [] in
- Hashtbl.iter (fun name v ->
- res := { eexpr = TConst(TString name); etype = gen.gcon.basic.tstring; epos = Ast.null_pos } :: !res;
- let name = Codegen.escape_res_name name true in
- let full_path = gen.gcon.file ^ "/src/" ^ name in
- mkdir_from_path full_path;
- let f = open_out_bin full_path in
- output_string f v;
- close_out f;
- out_files := (unique_full_path full_path) :: !out_files
- ) gen.gcon.resources;
- (try
- let c = get_cl (Hashtbl.find gen.gtypes (["haxe"], "Resource")) in
- let cf = PMap.find "content" c.cl_statics in
- cf.cf_expr <- Some ({ eexpr = TArrayDecl(!res); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = Ast.null_pos })
- with | Not_found -> ());
- run_filters gen;
- TypeParams.RenameTypeParameters.run gen;
- let t = Common.timer "code generation" in
- let parts = Str.split_delim (Str.regexp "[\\/]+") gen.gcon.file in
- mkdir_recursive "" parts;
- generate_modules_t gen "java" "src" change_path module_gen out_files;
- if not (Common.defined gen.gcon Define.KeepOldOutput) then
- clean_files (gen.gcon.file ^ "/src") !out_files gen.gcon.verbose;
- let path_s_desc path = path_s path [] in
- dump_descriptor gen ("hxjava_build.txt") path_s_desc (fun md -> path_s_desc (t_infos md).mt_path);
- if ( not (Common.defined gen.gcon Define.NoCompilation) ) then begin
- let old_dir = Sys.getcwd() in
- Sys.chdir gen.gcon.file;
- let cmd = "haxelib run hxjava hxjava_build.txt --haxe-version " ^ (string_of_int gen.gcon.version) ^ " --feature-level 1" in
- print_endline cmd;
- if gen.gcon.run_command cmd <> 0 then failwith "Build failed";
- Sys.chdir old_dir;
- end;
- t()
- (* end of configure function *)
- let before_generate con =
- let java_ver = try
- int_of_string (PMap.find "java_ver" con.defines)
- with | Not_found ->
- Common.define_value con Define.JavaVer "7";
- 7
- in
- 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");
- let rec loop i =
- Common.raw_define con ("java" ^ (string_of_int i));
- if i > 0 then loop (i - 1)
- in
- loop java_ver;
- ()
- let generate con =
- let exists = ref false in
- con.java_libs <- List.map (fun (file,std,close,la,gr) ->
- if String.ends_with file "hxjava-std.jar" then begin
- exists := true;
- (file,true,close,la,gr)
- end else
- (file,std,close,la,gr)) con.java_libs;
- if not !exists then
- failwith "Your version of hxjava is outdated. Please update it by running: `haxelib update hxjava`";
- let gen = new_ctx con in
- gen.gallow_tp_dynamic_conversion <- true;
- let basic = con.basic in
- (* make the basic functions in java *)
- let basic_fns =
- [
- mk_class_field "equals" (TFun(["obj",false,t_dynamic], basic.tbool)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "toString" (TFun([], basic.tstring)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "hashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "wait" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "notify" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "notifyAll" (TFun([], basic.tvoid)) true Ast.null_pos (Method MethNormal) [];
- ] in
- List.iter (fun cf -> gen.gbase_class_fields <- PMap.add cf.cf_name cf gen.gbase_class_fields) basic_fns;
- (try
- configure gen
- with | TypeNotFound path -> con.error ("Error. Module '" ^ (path_s path) ^ "' is required and was not included in build.") Ast.null_pos);
- debug_mode := false
- (** Java lib *)
- open JData
- type java_lib_ctx = {
- jcom : Common.context;
- (* current tparams context *)
- mutable jtparams : jtypes list;
- }
- exception ConversionError of string * pos
- let error s p = raise (ConversionError (s, p))
- let is_haxe_keyword = function
- | "callback" | "cast" | "extern" | "function" | "in" | "typedef" | "using" | "var" | "untyped" | "inline" -> true
- | _ -> false
- let jname_to_hx name =
- let name =
- if name <> "" && (String.get name 0 < 'A' || String.get name 0 > 'Z') then
- Char.escaped (Char.uppercase (String.get name 0)) ^ String.sub name 1 (String.length name - 1)
- else
- name
- in
- let name = String.concat "__" (String.nsplit name "_") in
- String.map (function | '$' -> '_' | c -> c) name
- let normalize_pack pack =
- List.map (function
- | "" -> ""
- | str when String.get str 0 >= 'A' && String.get str 0 <= 'Z' ->
- String.lowercase str
- | str -> str
- ) pack
- let jpath_to_hx (pack,name) = match pack, name with
- | ["haxe";"root"], name -> [], name
- | "com" :: ("oracle" | "sun") :: _, _
- | "javax" :: _, _
- | "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _
- | "sun" :: _, _
- | "sunw" :: _, _ -> "java" :: normalize_pack pack, jname_to_hx name
- | pack, name -> normalize_pack pack, jname_to_hx name
- let real_java_path ctx (pack,name) =
- path_s (pack, name)
- let lookup_jclass com path =
- let path = jpath_to_hx path in
- List.fold_right (fun (_,_,_,_,get_raw_class) acc ->
- match acc with
- | None -> get_raw_class path
- | Some p -> Some p
- ) com.java_libs None
- let mk_type_path ctx path params =
- let name, sub = try
- let p, _ = String.split (snd path) "$" in
- jname_to_hx p, Some (jname_to_hx (snd path))
- with | Invalid_string ->
- jname_to_hx (snd path), None
- in
- let pack = fst (jpath_to_hx path) in
- let pack, sub, name = match path with
- | [], ("Float" as c)
- | [], ("Int" as c)
- | [], ("Single" as c)
- | [], ("Bool" as c)
- | [], ("Dynamic" as c)
- | [], ("Iterator" as c)
- | [], ("ArrayAccess" as c)
- | [], ("Iterable" as c) ->
- [], Some c, "StdTypes"
- | [], ("String" as c) ->
- ["std"], None, c
- | _ ->
- pack, sub, name
- in
- CTPath {
- tpackage = pack;
- tname = name;
- tparams = params;
- tsub = sub;
- }
- let has_tparam name params = List.exists(fun (n,_,_) -> n = name) params
- let rec convert_arg ctx p arg =
- match arg with
- | TAny | TType (WSuper, _) -> TPType (mk_type_path ctx ([], "Dynamic") [])
- | TType (_, jsig) -> TPType (convert_signature ctx p jsig)
- and convert_signature ctx p jsig =
- match jsig with
- | TByte -> mk_type_path ctx (["java"; "types"], "Int8") []
- | TChar -> mk_type_path ctx (["java"; "types"], "Char16") []
- | TDouble -> mk_type_path ctx ([], "Float") []
- | TFloat -> mk_type_path ctx ([], "Single") []
- | TInt -> mk_type_path ctx ([], "Int") []
- | TLong -> mk_type_path ctx (["haxe"], "Int64") []
- | TShort -> mk_type_path ctx (["java"; "types"], "Int16") []
- | TBool -> mk_type_path ctx ([], "Bool") []
- | TObject ( (["haxe";"root"], name), args ) -> mk_type_path ctx ([], name) (List.map (convert_arg ctx p) args)
- (** nullable types *)
- (* replaced from Null<Type> to the actual abstract type to fix #2738 *)
- (* | TObject ( (["java";"lang"], "Integer"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Int") []) ] *)
- (* | TObject ( (["java";"lang"], "Double"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Float") []) ] *)
- (* | TObject ( (["java";"lang"], "Float"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Single") []) ] *)
- (* | TObject ( (["java";"lang"], "Boolean"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Bool") []) ] *)
- (* | TObject ( (["java";"lang"], "Byte"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int8") []) ] *)
- (* | TObject ( (["java";"lang"], "Character"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Char16") []) ] *)
- (* | TObject ( (["java";"lang"], "Short"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int16") []) ] *)
- (* | TObject ( (["java";"lang"], "Long"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["haxe"], "Int64") []) ] *)
- (** other std types *)
- | TObject ( (["java";"lang"], "Object"), [] ) -> mk_type_path ctx ([], "Dynamic") []
- | TObject ( (["java";"lang"], "String"), [] ) -> mk_type_path ctx ([], "String") []
- | TObject ( (["java";"lang"], "Enum"), [_] ) -> mk_type_path ctx ([], "EnumValue") []
- (** other types *)
- | TObject ( path, [] ) ->
- (match lookup_jclass ctx.jcom path with
- | Some (jcl, _, _) -> mk_type_path ctx path (List.map (fun _ -> convert_arg ctx p TAny) jcl.ctypes)
- | None -> mk_type_path ctx path [])
- | TObject ( path, args ) -> mk_type_path ctx path (List.map (convert_arg ctx p) args)
- | TObjectInner (pack, (name, params) :: inners) ->
- let actual_param = match List.rev inners with
- | (_, p) :: _ -> p
- | _ -> assert false in
- mk_type_path ctx (pack, name ^ "$" ^ String.concat "$" (List.map fst inners)) (List.map (fun param -> convert_arg ctx p param) actual_param)
- | TObjectInner (pack, inners) -> assert false
- | TArray (jsig, _) -> mk_type_path ctx (["java"], "NativeArray") [ TPType (convert_signature ctx p jsig) ]
- | TMethod _ -> JReader.error "TMethod cannot be converted directly into Complex Type"
- | TTypeParameter s -> (match ctx.jtparams with
- | cur :: others ->
- if has_tparam s cur then
- mk_type_path ctx ([], s) []
- else begin
- if ctx.jcom.verbose && not(List.exists (has_tparam s) others) then print_endline ("Type parameter " ^ s ^ " was not found while building type!");
- mk_type_path ctx ([], "Dynamic") []
- end
- | _ ->
- if ctx.jcom.verbose then print_endline ("Empty type parameter stack!");
- mk_type_path ctx ([], "Dynamic") [])
- let convert_constant ctx p const =
- Option.map_default (function
- | ConstString s -> Some (EConst (String s), p)
- | ConstInt i -> Some (EConst (Int (Printf.sprintf "%ld" i)), p)
- | ConstFloat f | ConstDouble f -> Some (EConst (Float (Printf.sprintf "%E" f)), p)
- | _ -> None) None const
- let rec same_sig parent jsig =
- match jsig with
- | TObject (p,targs) -> parent = p || List.exists (function | TType (_,s) -> same_sig parent s | _ -> false) targs
- | TObjectInner(p, ntargs) ->
- parent = (p, String.concat "$" (List.map fst ntargs)) ||
- List.exists (fun (_,targs) -> List.exists (function | TType(_,s) -> same_sig parent s | _ -> false) targs) ntargs
- | TArray(s,_) -> same_sig parent s
- | _ -> false
- let convert_param ctx p parent param =
- let name, constraints = match param with
- | (name, Some extends_sig, implem_sig) ->
- name, extends_sig :: implem_sig
- | (name, None, implemem_sig) ->
- name, implemem_sig
- in
- let constraints = List.map (fun s -> if same_sig parent s then (TObject( (["java";"lang"], "Object"), [])) else s) constraints in
- {
- tp_name = name;
- tp_params = [];
- tp_constraints = List.map (convert_signature ctx p) constraints;
- }
- let get_type_path ctx ct = match ct with | CTPath p -> p | _ -> assert false
- let is_override field =
- List.exists (function | AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), _ ) }] -> true | _ -> false) field.jf_attributes
- let mk_override field =
- { field with jf_attributes = ((AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), [] ); ann_elements = [] }]) :: field.jf_attributes) }
- let del_override field =
- { field with jf_attributes = List.filter (fun a -> not (is_override_attrib a)) field.jf_attributes }
- let get_canonical ctx p pack name =
- (Meta.JavaCanonical, [EConst (String (String.concat "." pack)), p; EConst (String name), p], p)
- let convert_java_enum ctx p pe =
- 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
- let data = ref [] in
- List.iter (fun f ->
- (* if List.mem JEnum f.jf_flags then *)
- match f.jf_vmsignature with
- | TObject( path, [] ) when path = pe.cpath && List.mem JStatic f.jf_flags && List.mem JFinal f.jf_flags ->
- data := { ec_name = f.jf_name; ec_doc = None; ec_meta = []; ec_args = []; ec_pos = p; ec_params = []; ec_type = None; } :: !data;
- | _ -> ()
- ) pe.cfields;
- EEnum {
- d_name = jname_to_hx (snd pe.cpath);
- d_doc = None;
- d_params = []; (* enums never have type parameters *)
- d_meta = !meta;
- d_flags = [EExtern];
- d_data = List.rev !data;
- }
- let convert_java_field ctx p jc field =
- let p = { p with pfile = p.pfile ^" (" ^field.jf_name ^")" } in
- let cff_doc = None in
- let cff_pos = p in
- let cff_meta = ref [] in
- let cff_access = ref [] in
- let cff_name = match field.jf_name with
- | "<init>" -> "new"
- | "<clinit>"-> raise Exit (* __init__ field *)
- | name when String.length name > 5 ->
- (match String.sub name 0 5 with
- | "__hx_" | "this$" -> raise Exit
- | _ -> name)
- | name -> name
- in
- let jf_constant = ref field.jf_constant in
- let readonly = ref false in
- List.iter (function
- | JPublic -> cff_access := APublic :: !cff_access
- | JPrivate -> raise Exit (* private instances aren't useful on externs *)
- | JProtected -> cff_access := APrivate :: !cff_access
- | JStatic -> cff_access := AStatic :: !cff_access
- | JFinal ->
- cff_meta := (Meta.Final, [], p) :: !cff_meta;
- (match field.jf_kind, field.jf_vmsignature, field.jf_constant with
- | JKField, TObject _, _ ->
- jf_constant := None
- | JKField, _, Some _ ->
- readonly := true;
- jf_constant := None;
- | _ -> jf_constant := None)
- (* | JSynchronized -> cff_meta := (Meta.Synchronized, [], p) :: !cff_meta *)
- | JVolatile -> cff_meta := (Meta.Volatile, [], p) :: !cff_meta
- | JTransient -> cff_meta := (Meta.Transient, [], p) :: !cff_meta
- (* | JVarArgs -> cff_meta := (Meta.VarArgs, [], p) :: !cff_meta *)
- | _ -> ()
- ) field.jf_flags;
- List.iter (function
- | AttrDeprecated when jc.cpath <> (["java";"util"],"Date") -> cff_meta := (Meta.Deprecated, [], p) :: !cff_meta
- (* TODO: pass anotations as @:meta *)
- | AttrVisibleAnnotations ann ->
- List.iter (function
- | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } ->
- cff_access := AOverride :: !cff_access
- | _ -> ()
- ) ann
- | _ -> ()
- ) field.jf_attributes;
- List.iter (fun jsig ->
- match convert_signature ctx p jsig with
- | CTPath path ->
- cff_meta := (Meta.Throws, [Ast.EConst (Ast.String (path_s (path.tpackage,path.tname))), p],p) :: !cff_meta
- | _ -> ()
- ) field.jf_throws;
- let kind = match field.jf_kind with
- | JKField when !readonly ->
- FProp ("default", "null", Some (convert_signature ctx p field.jf_signature), None)
- | JKField ->
- FVar (Some (convert_signature ctx p field.jf_signature), None)
- | JKMethod ->
- match field.jf_signature with
- | TMethod (args, ret) ->
- let old_types = ctx.jtparams in
- (match ctx.jtparams with
- | c :: others -> ctx.jtparams <- (c @ field.jf_types) :: others
- | [] -> ctx.jtparams <- field.jf_types :: []);
- let i = ref 0 in
- let args = List.map (fun s ->
- incr i;
- "param" ^ string_of_int !i, false, Some(convert_signature ctx p s), None
- ) args in
- let t = Option.map_default (convert_signature ctx p) (mk_type_path ctx ([], "Void") []) ret in
- cff_meta := (Meta.Overload, [], p) :: !cff_meta;
- let types = List.map (function
- | (name, Some ext, impl) ->
- {
- tp_name = name;
- tp_params = [];
- tp_constraints = List.map (convert_signature ctx p) (ext :: impl);
- }
- | (name, None, impl) ->
- {
- tp_name = name;
- tp_params = [];
- tp_constraints = List.map (convert_signature ctx p) (impl);
- }
- ) field.jf_types in
- ctx.jtparams <- old_types;
- FFun ({
- f_params = types;
- f_args = args;
- f_type = Some t;
- f_expr = None
- })
- | _ -> error "Method signature was expected" p
- in
- let cff_name, cff_meta =
- match String.get cff_name 0 with
- | '%' ->
- let name = (String.sub cff_name 1 (String.length cff_name - 1)) in
- if not (is_haxe_keyword name) then
- cff_meta := (Meta.Deprecated, [EConst(String(
- "This static field `_" ^ name ^ "` is deprecated and will be removed in later versions. Please use `" ^ name ^ "` instead")
- ),p], p) :: !cff_meta;
- "_" ^ name,
- (Meta.Native, [EConst (String (name) ), cff_pos], cff_pos) :: !cff_meta
- | _ ->
- match String.nsplit cff_name "$" with
- | [ no_dollar ] ->
- cff_name, !cff_meta
- | parts ->
- String.concat "_" parts,
- (Meta.Native, [EConst (String (cff_name) ), cff_pos], cff_pos) :: !cff_meta
- in
- if PMap.mem "java_loader_debug" ctx.jcom.defines then
- 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);
- {
- cff_name = cff_name;
- cff_doc = cff_doc;
- cff_pos = cff_pos;
- cff_meta = cff_meta;
- cff_access = !cff_access;
- cff_kind = kind
- }
- let rec japply_params params jsig = match params with
- | [] -> jsig
- | _ -> match jsig with
- | TTypeParameter s -> (try
- List.assoc s params
- with | Not_found -> jsig)
- | TObject(p,tl) ->
- TObject(p, args params tl)
- | TObjectInner(sl, stll) ->
- TObjectInner(sl, List.map (fun (s,tl) -> (s, args params tl)) stll)
- | TArray(s,io) ->
- TArray(japply_params params s, io)
- | TMethod(sl, sopt) ->
- TMethod(List.map (japply_params params) sl, Option.map (japply_params params) sopt)
- | _ -> jsig
- and args params tl = match params with
- | [] -> tl
- | _ -> List.map (function
- | TAny -> TAny
- | TType(w,s) -> TType(w,japply_params params s)) tl
- let mk_params jtypes = List.map (fun (s,_,_) -> (s,TTypeParameter s)) jtypes
- let convert_java_class ctx p jc =
- match List.mem JEnum jc.cflags with
- | true -> (* is enum *)
- [convert_java_enum ctx p jc]
- | false ->
- let flags = ref [HExtern] in
- if PMap.mem "java_loader_debug" ctx.jcom.defines then begin
- let sup = jc.csuper :: jc.cinterfaces in
- print_endline ("converting " ^ (if List.mem JAbstract jc.cflags then "abstract " else "") ^ JData.path_s jc.cpath ^ " : " ^ (String.concat ", " (List.map s_sig sup)));
- end;
- (* todo: instead of JavaNative, use more specific definitions *)
- 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
- let force_check = Common.defined ctx.jcom Define.ForceLibCheck in
- if not force_check then
- meta := (Meta.LibType,[],p) :: !meta;
- let is_interface = ref false in
- List.iter (fun f -> match f with
- | JFinal -> meta := (Meta.Final, [], p) :: !meta
- | JInterface ->
- is_interface := true;
- flags := HInterface :: !flags
- | JAbstract -> meta := (Meta.Abstract, [], p) :: !meta
- | JAnnotation -> meta := (Meta.Annotation, [], p) :: !meta
- | _ -> ()
- ) jc.cflags;
- (match jc.csuper with
- | TObject( (["java";"lang"], "Object"), _ ) -> ()
- | TObject( (["haxe";"lang"], "HxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta
- | _ -> flags := HExtends (get_type_path ctx (convert_signature ctx p jc.csuper)) :: !flags
- );
- List.iter (fun i ->
- match i with
- | TObject ( (["haxe";"lang"], "IHxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta
- | _ -> flags :=
- if !is_interface then
- HExtends (get_type_path ctx (convert_signature ctx p i)) :: !flags
- else
- HImplements (get_type_path ctx (convert_signature ctx p i)) :: !flags
- ) jc.cinterfaces;
- let fields = ref [] in
- let jfields = ref [] in
- if jc.cpath <> (["java";"lang"], "CharSequence") then
- List.iter (fun f ->
- try
- if !is_interface && List.mem JStatic f.jf_flags then
- ()
- else begin
- fields := convert_java_field ctx p jc f :: !fields;
- jfields := f :: !jfields
- end
- with
- | Exit -> ()
- ) (jc.cfields @ jc.cmethods);
- (* make sure the throws types are imported correctly *)
- let imports = List.concat (List.map (fun f ->
- List.map (fun jsig ->
- match convert_signature ctx p jsig with
- | CTPath path ->
- let pos = { p with pfile = p.pfile ^ " (" ^ f.jf_name ^" @:throws)" } in
- EImport( List.map (fun s -> s,pos) (path.tpackage @ [path.tname]), INormal )
- | _ -> assert false
- ) f.jf_throws
- ) jc.cmethods) in
- (EClass {
- d_name = jname_to_hx (snd jc.cpath);
- d_doc = None;
- d_params = List.map (convert_param ctx p jc.cpath) jc.ctypes;
- d_meta = !meta;
- d_flags = !flags;
- d_data = !fields;
- }) :: imports
- let create_ctx com =
- {
- jcom = com;
- jtparams = [];
- }
- let rec has_type_param = function
- | TTypeParameter _ -> true
- | TMethod (lst, opt) -> List.exists has_type_param lst || Option.map_default has_type_param false opt
- | TArray (s,_) -> has_type_param s
- | TObjectInner (_, stpl) -> List.exists (fun (_,sigs) -> List.exists has_type_param_arg sigs) stpl
- | TObject(_, pl) -> List.exists has_type_param_arg pl
- | _ -> false
- and has_type_param_arg = function | TType(_,s) -> has_type_param s | _ -> false
- let rec japply_params jparams jsig = match jparams with
- | [] -> jsig
- | _ ->
- match jsig with
- | TObject(path,p) ->
- TObject(path, List.map (japply_params_tp jparams ) p)
- | TObjectInner(sl,stargl) ->
- TObjectInner(sl,List.map (fun (s,targ) -> (s, List.map (japply_params_tp jparams) targ)) stargl)
- | TArray(jsig,io) ->
- TArray(japply_params jparams jsig,io)
- | TMethod(args,ret) ->
- TMethod(List.map (japply_params jparams ) args, Option.map (japply_params jparams ) ret)
- | TTypeParameter s -> (try
- List.assoc s jparams
- with | Not_found -> jsig)
- | _ -> jsig
- and japply_params_tp jparams jtype_argument = match jtype_argument with
- | TAny -> TAny
- | TType(w,jsig) -> TType(w,japply_params jparams jsig)
- let mk_jparams jtypes params = match jtypes, params with
- | [], [] -> []
- | _, [] -> List.map (fun (s,_,_) -> s, TObject( (["java";"lang"], "Object"), [] ) ) jtypes
- | _ -> List.map2 (fun (s,_,_) jt -> match jt with
- | TAny -> s, TObject((["java";"lang"],"Object"),[])
- | TType(_,jsig) -> s, jsig) jtypes params
- let rec compatible_signature_arg ?arg_test f1 f2 =
- let arg_test = match arg_test with
- | None -> (fun _ _ -> true)
- | Some a -> a
- in
- if f1 = f2 then
- true
- else match f1, f2 with
- | TObject(p,a), TObject(p2,a2) -> p = p2 && arg_test a a2
- | TObjectInner(sl, stal), TObjectInner(sl2, stal2) -> sl = sl2 && List.map fst stal = List.map fst stal2
- | TArray(s,_) , TArray(s2,_) -> compatible_signature_arg s s2
- | TTypeParameter t1 , TTypeParameter t2 -> t1 = t2
- | _ -> false
- let rec compatible_param p1 p2 = match p1, p2 with
- | TType (_,s1), TType(_,s2) -> compatible_signature_arg ~arg_test:compatible_tparams s1 s2
- | TAny, TType(_, TObject( (["java";"lang"],"Object"), _ )) -> true
- | TType(_, TObject( (["java";"lang"],"Object"), _ )), TAny -> true
- | _ -> false
- and compatible_tparams p1 p2 = try match p1, p2 with
- | [], [] -> true
- | _, [] ->
- let p2 = List.map (fun _ -> TAny) p1 in
- List.for_all2 compatible_param p1 p2
- | [], _ ->
- let p1 = List.map (fun _ -> TAny) p2 in
- List.for_all2 compatible_param p1 p2
- | _, _ ->
- List.for_all2 compatible_param p1 p2
- with | Invalid_argument("List.for_all2") -> false
- let get_adapted_sig f f2 = match f.jf_types with
- | [] ->
- f.jf_signature
- | _ ->
- let jparams = mk_jparams f.jf_types (List.map (fun (s,_,_) -> TType(WNone, TTypeParameter s)) f2.jf_types) in
- japply_params jparams f.jf_signature
- let compatible_methods f1 f2 =
- if List.length f1.jf_types <> List.length f2.jf_types then
- false
- else match (get_adapted_sig f1 f2), f2.jf_signature with
- | TMethod(a1,_), TMethod(a2,_) when List.length a1 = List.length a2 ->
- List.for_all2 compatible_signature_arg a1 a2
- | _ -> false
- let jcl_from_jsig com jsig =
- let path, params = match jsig with
- | TObject(path, params) ->
- path,params
- | TObjectInner(sl, stll) ->
- let last_params = ref [] in
- let real_path = sl, String.concat "$" (List.map (fun (s,p) -> last_params := p; s) stll) in
- real_path, !last_params
- | _ -> raise Not_found
- in
- match lookup_jclass com path with
- | None -> raise Not_found
- | Some(c,_,_) -> c,params
- let jclass_with_params com cls params = try
- match cls.ctypes with
- | [] -> cls
- | _ ->
- let jparams = mk_jparams cls.ctypes params in
- { cls with
- cfields = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cfields;
- cmethods = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cmethods;
- csuper = japply_params jparams cls.csuper;
- cinterfaces = List.map (japply_params jparams) cls.cinterfaces;
- }
- with Invalid_argument("List.map2") ->
- if com.verbose then prerr_endline ("Differing parameters for class: " ^ path_s cls.cpath);
- cls
- let is_object = function | TObject( (["java";"lang"], "Object"), [] ) -> true | _ -> false
- let is_tobject = function | TObject _ | TObjectInner _ -> true | _ -> false
- let simplify_args args =
- if List.for_all (function | TAny -> true | _ -> false) args then [] else args
- let compare_type com s1 s2 =
- if s1 = s2 then
- 0
- else if not (is_tobject s1) then
- if is_tobject s2 then (* Dynamic *)
- 1
- else if compatible_signature_arg s1 s2 then
- 0
- else
- raise Exit
- else if not (is_tobject s2) then
- -1
- else begin
- let rec loop ?(first_error=true) s1 s2 : bool =
- if is_object s1 then
- s1 = s2
- else if compatible_signature_arg s1 s2 then begin
- let p1, p2 = match s1, s2 with
- | TObject(_, p1), TObject(_,p2) ->
- p1, p2
- | TObjectInner(_, npl1), TObjectInner(_, npl2) ->
- snd (List.hd (List.rev npl1)), snd (List.hd (List.rev npl2))
- | _ -> assert false (* not tobject *)
- in
- let p1, p2 = simplify_args p1, simplify_args p2 in
- let lp1 = List.length p1 in
- let lp2 = List.length p2 in
- if lp1 > lp2 then
- true
- else if lp2 > lp1 then
- false
- else begin
- (* if compatible tparams, it's fine *)
- if not (compatible_tparams p1 p2) then
- raise Exit; (* meaning: found, but incompatible type parameters *)
- true
- end
- end else try
- let c, p = jcl_from_jsig com s1 in
- let jparams = mk_jparams c.ctypes p in
- let super = japply_params jparams c.csuper in
- let implements = List.map (japply_params jparams) c.cinterfaces in
- loop ~first_error:first_error super s2 || List.exists (fun super -> loop ~first_error:first_error super s2) implements
- with | Not_found ->
- prerr_endline ("-java-lib: The type " ^ (s_sig s1) ^ " is referred but was not found. Compilation may not occur correctly.");
- prerr_endline "Did you forget to include a needed lib?";
- if first_error then
- not (loop ~first_error:false s2 s1)
- else
- false
- in
- if loop s1 s2 then
- if loop s2 s1 then
- 0
- else
- 1
- else
- if loop s2 s1 then
- -1
- else
- -2
- end
- (* given a list of same overload functions, choose the best (or none) *)
- let select_best com flist =
- let rec loop cur_best = function
- | [] ->
- Some cur_best
- | f :: flist -> match get_adapted_sig f cur_best, cur_best.jf_signature with
- | TMethod(_,Some r), TMethod(_, Some r2) -> (try
- match compare_type com r r2 with
- | 0 -> (* same type - select any of them *)
- loop cur_best flist
- | 1 ->
- loop f flist
- | -1 ->
- loop cur_best flist
- | -2 -> (* error - no type is compatible *)
- if com.verbose then prerr_endline (f.jf_name ^ ": The types " ^ (s_sig r) ^ " and " ^ (s_sig r2) ^ " are incompatible");
- (* bet that the current best has "beaten" other types *)
- loop cur_best flist
- | _ -> assert false
- with | Exit -> (* incompatible type parameters *)
- (* error mode *)
- if com.verbose then prerr_endline (f.jf_name ^ ": Incompatible argument return signatures: " ^ (s_sig r) ^ " and " ^ (s_sig r2));
- None)
- | TMethod _, _ -> (* select the method *)
- loop f flist
- | _ ->
- loop cur_best flist
- in
- match loop (List.hd flist) (List.tl flist) with
- | Some f ->
- Some f
- | None -> match List.filter (fun f -> not (is_override f)) flist with
- (* error mode; take off all override methods *)
- | [] -> None
- | f :: [] -> Some f
- | f :: flist -> Some f (* pick one *)
- (**** begin normalize_jclass helpers ****)
- let fix_overrides_jclass com cls =
- let force_check = Common.defined com Define.ForceLibCheck in
- let methods = if force_check then List.map (fun f -> del_override f) cls.cmethods else cls.cmethods in
- let cmethods = methods in
- let super_fields = [] in
- let super_methods = [] in
- let nonstatics = List.filter (fun f -> not (List.mem JStatic f.jf_flags)) (cls.cfields @ cls.cmethods) in
- let is_pub = fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags in
- let cmethods, super_fields = if not (List.mem JInterface cls.cflags) then
- List.filter is_pub cmethods,
- List.filter is_pub super_fields
- else
- cmethods,super_fields
- in
- let rec loop cls super_methods super_fields cmethods nonstatics = try
- match cls.csuper with
- | TObject((["java";"lang"],"Object"),_) ->
- super_methods,super_fields,cmethods,nonstatics
- | _ ->
- let cls, params = jcl_from_jsig com cls.csuper in
- let cls = jclass_with_params com cls params in
- let nonstatics = (List.filter (fun f -> (List.mem JStatic f.jf_flags)) (cls.cfields @ cls.cmethods)) @ nonstatics in
- let super_methods = cls.cmethods @ super_methods in
- let super_fields = cls.cfields @ super_fields in
- let cmethods = if force_check then begin
- let overriden = ref [] in
- let cmethods = List.map (fun jm ->
- (* TODO rewrite/standardize empty spaces *)
- if not (is_override jm) && not (List.mem JStatic jm.jf_flags) && List.exists (fun msup ->
- let ret = msup.jf_name = jm.jf_name && not(List.mem JStatic msup.jf_flags) && compatible_methods msup jm in
- if ret then begin
- let f = mk_override msup in
- overriden := { f with jf_flags = jm.jf_flags } :: !overriden
- end;
- ret
- ) cls.cmethods then
- mk_override jm
- else
- jm
- ) cmethods in
- !overriden @ cmethods
- end else
- cmethods
- in
- loop cls super_methods super_fields cmethods nonstatics
- with | Not_found ->
- super_methods,super_fields,cmethods,nonstatics
- in
- loop cls super_methods super_fields cmethods nonstatics
- let normalize_jclass com cls =
- (* after adding the noCheck metadata, this option will annotate what changes were needed *)
- (* and that are now deprecated *)
- let force_check = Common.defined com Define.ForceLibCheck in
- (* fix overrides *)
- let super_methods, super_fields, cmethods, nonstatics = fix_overrides_jclass com cls in
- let all_methods = cmethods @ super_methods in
- (* look for interfaces and add missing implementations (may happen on abstracts or by vmsig differences *)
- (* (libType): even with libType enabled, we need to add these missing fields - otherwise we won't be able to use them from Haxe *)
- let added_interface_fields = ref [] in
- let rec loop_interface abstract cls iface = try
- match iface with
- | TObject ((["java";"lang"],"Object"), _) -> ()
- | TObject (path,_) when path = cls.cpath -> ()
- | _ ->
- let cif, params = jcl_from_jsig com iface in
- let cif = jclass_with_params com cif params in
- List.iter (fun jf ->
- 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
- let jf = if abstract && force_check then del_override jf else jf in
- let jf = { jf with jf_flags = JPublic :: jf.jf_flags } in (* interfaces implementations are always public *)
- added_interface_fields := jf :: !added_interface_fields;
- end
- ) cif.cmethods;
- (* we don't need to loop again in the interface unless we are in an abstract class, since these interfaces are already normalized *)
- if abstract then List.iter (loop_interface abstract cif) cif.cinterfaces;
- with Not_found -> ()
- in
- List.iter (loop_interface (List.mem JAbstract cls.cflags) cls) cls.cinterfaces;
- let nonstatics = !added_interface_fields @ nonstatics in
- let cmethods = !added_interface_fields @ cmethods in
- (* for each added field in the interface, lookup in super_methods possible methods to include *)
- (* so we can choose the better method still *)
- let cmethods = if not force_check then
- cmethods
- else
- List.fold_left (fun cmethods im ->
- (* see if any of the added_interface_fields need to be declared as override *)
- let f = List.find_all (fun jf -> jf.jf_name = im.jf_name && compatible_methods jf im) super_methods in
- let f = List.map mk_override f in
- f @ cmethods
- ) cmethods !added_interface_fields;
- in
- (* take off equals, hashCode and toString from interface *)
- let cmethods = if List.mem JInterface cls.cflags then List.filter (fun jf -> match jf.jf_name, jf.jf_vmsignature with
- | "equals", TMethod([TObject( (["java";"lang"],"Object"), _)],_)
- | "hashCode", TMethod([], _)
- | "toString", TMethod([], _) -> false
- | _ -> true
- ) cmethods
- else
- cmethods
- in
- (* change field name to not collide with haxe keywords and with static/non-static members *)
- let fold_field acc f =
- let change, both = match f.jf_name with
- | _ when List.mem JStatic f.jf_flags && List.exists (fun f2 -> f.jf_name = f2.jf_name) nonstatics -> true, true
- | _ -> is_haxe_keyword f.jf_name, false
- in
- let f2 = if change then
- { f with jf_name = "%" ^ f.jf_name }
- else
- f
- in
- if both then f :: f2 :: acc else f2 :: acc
- in
- (* change static fields that have the same name as methods *)
- let cfields = List.fold_left fold_field [] cls.cfields in
- let cmethods = List.fold_left fold_field [] cmethods in
- (* take off variable fields that have the same name as methods *)
- (* and take off variables that already have been declared *)
- 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
- let cfields = List.filter (fun f ->
- if List.mem JStatic f.jf_flags then
- not (List.exists (filter_field f) cmethods)
- else
- 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
- in
- (* now filter any method that clashes with a field - on a superclass *)
- let cmethods = if force_check then List.filter (fun f ->
- if List.mem JStatic f.jf_flags then
- true
- else
- not (List.exists (filter_field f) super_fields) ) cmethods
- else
- cmethods
- in
- (* removing duplicate fields. They are there because of return type covariance in Java *)
- (* Also, if a method overrides a previous definition, and changes a type parameters' variance, *)
- (* we will take it off *)
- (* this means that some rare codes will never compile on Haxe, but unless Haxe adds variance support *)
- (* I can't see how this can be any different *)
- let rec loop acc = function
- | [] -> acc
- | f :: cmeths ->
- match List.partition (fun f2 -> f.jf_name = f2.jf_name && compatible_methods f f2) cmeths with
- | [], cmeths ->
- loop (f :: acc) cmeths
- | flist, cmeths -> match select_best com (f :: flist) with
- | None ->
- loop acc cmeths
- | Some f ->
- loop (f :: acc) cmeths
- in
- (* last pass: take off all cfields that are internal / private (they won't be accessible anyway) *)
- let cfields = List.filter(fun f -> List.exists (fun f -> f = JPublic || f = JProtected) f.jf_flags) cfields in
- let cmethods = loop [] cmethods in
- { cls with cfields = cfields; cmethods = cmethods }
- (**** end normalize_jclass helpers ****)
- let get_classes_zip zip =
- let ret = ref [] in
- List.iter (function
- | { Zip.is_directory = false; Zip.filename = f } when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" ->
- (match List.rev (String.nsplit f "/") with
- | clsname :: pack ->
- if not (String.contains clsname '$') then begin
- let path = jpath_to_hx (List.rev pack, String.sub clsname 0 (String.length clsname - 6)) in
- ret := path :: !ret
- end
- | _ ->
- ret := ([], jname_to_hx f) :: !ret)
- | _ -> ()
- ) (Zip.entries zip);
- !ret
- let add_java_lib com file std =
- let file = if Sys.file_exists file then
- file
- else try Common.find_file com file with
- | Not_found -> try Common.find_file com (file ^ ".jar") with
- | Not_found ->
- failwith ("Java lib " ^ file ^ " not found")
- in
- let hxpack_to_jpack = Hashtbl.create 16 in
- let get_raw_class, close, list_all_files =
- (* check if it is a directory or jar file *)
- match (Unix.stat file).st_kind with
- | S_DIR -> (* open classes directly from directory *)
- let all = ref [] in
- let rec iter_files pack dir path = try
- let file = Unix.readdir dir in
- let filepath = path ^ "/" ^ file in
- (if String.ends_with file ".class" then
- let file = String.sub file 0 (String.length file - 6) in
- let path = jpath_to_hx (pack,file) in
- all := path :: !all;
- Hashtbl.add hxpack_to_jpack path (pack,file)
- else if (Unix.stat filepath).st_kind = S_DIR && file <> "." && file <> ".." then
- let pack = pack @ [file] in
- iter_files (pack) (Unix.opendir filepath) filepath);
- iter_files pack dir path
- with | End_of_file | Unix.Unix_error _ ->
- Unix.closedir dir
- in
- iter_files [] (Unix.opendir file) file;
- let all = !all in
- (fun (pack, name) ->
- let real_path = file ^ "/" ^ (String.concat "/" pack) ^ "/" ^ (name ^ ".class") in
- try
- let data = Std.input_file ~bin:true real_path in
- Some(JReader.parse_class (IO.input_string data), real_path, real_path)
- with
- | _ -> None), (fun () -> ()), (fun () -> all)
- | _ -> (* open zip file *)
- let closed = ref false in
- let zip = ref (Zip.open_in file) in
- let check_open () =
- if !closed then begin
- prerr_endline ("JAR file " ^ file ^ " already closed"); (* if this happens, find when *)
- zip := Zip.open_in file;
- closed := false
- end
- in
- List.iter (function
- | { Zip.is_directory = false; Zip.filename = filename } when String.ends_with filename ".class" ->
- let pack = String.nsplit filename "/" in
- (match List.rev pack with
- | [] -> ()
- | name :: pack ->
- let name = String.sub name 0 (String.length name - 6) in
- let pack = List.rev pack in
- Hashtbl.add hxpack_to_jpack (jpath_to_hx (pack,name)) (pack,name))
- | _ -> ()
- ) (Zip.entries !zip);
- (fun (pack, name) ->
- check_open();
- try
- let location = (String.concat "/" (pack @ [name]) ^ ".class") in
- let entry = Zip.find_entry !zip location in
- let data = Zip.read_entry !zip entry in
- Some(JReader.parse_class (IO.input_string data), file, file ^ "@" ^ location)
- with
- | Not_found ->
- None),
- (fun () -> if not !closed then begin closed := true; Zip.close_in !zip end),
- (fun () -> check_open(); get_classes_zip !zip)
- in
- let cached_types = Hashtbl.create 12 in
- let get_raw_class path =
- try
- Hashtbl.find cached_types path
- with | Not_found -> try
- let pack, name = Hashtbl.find hxpack_to_jpack path in
- let try_file (pack,name) =
- match get_raw_class (pack,name) with
- | None ->
- Hashtbl.add cached_types path None;
- None
- | Some (i, p1, p2) ->
- Hashtbl.add cached_types path (Some(i,p1,p2)); (* type loop normalization *)
- let ret = Some (normalize_jclass com i, p1, p2) in
- Hashtbl.replace cached_types path ret;
- ret
- in
- try_file (pack,name)
- with Not_found ->
- None
- in
- let replace_canonical_name p pack name_original name_replace decl =
- let mk_meta name = (Meta.JavaCanonical, [EConst (String (String.concat "." pack)), p; EConst(String name), p], p) in
- let add_meta name metas =
- if Meta.has Meta.JavaCanonical metas then
- List.map (function
- | (Meta.JavaCanonical,[EConst (String cpack), _; EConst(String cname), _],_) ->
- let did_replace,name = String.replace cname name_original name_replace in
- if not did_replace then print_endline (cname ^ " -> " ^ name_original ^ " -> " ^ name_replace);
- mk_meta name
- | m -> m
- ) metas
- else
- mk_meta name :: metas
- in
- match decl with
- | EClass c ->
- EClass { c with d_meta = add_meta c.d_name c.d_meta }
- | EEnum e ->
- EEnum { e with d_meta = add_meta e.d_name e.d_meta }
- | EAbstract a ->
- EAbstract { a with d_meta = add_meta a.d_name a.d_meta }
- | d -> d
- in
- let rec build ctx path p types =
- try
- if List.mem path !types then
- None
- else begin
- types := path :: !types;
- match get_raw_class path, path with
- | None, ([], c) -> build ctx (["haxe";"root"], c) p types
- | None, _ -> None
- | Some (cls, real_path, pos_path), _ ->
- if com.verbose then print_endline ("Parsed Java class " ^ (path_s cls.cpath));
- let old_types = ctx.jtparams in
- ctx.jtparams <- cls.ctypes :: ctx.jtparams;
- let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in
- let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in
- let ppath = Hashtbl.find hxpack_to_jpack path in
- let inner = List.fold_left (fun acc (path,out,_,_) ->
- let path = jpath_to_hx path in
- (if out <> Some ppath then
- acc
- else match build ctx path p types with
- | Some(_,(_, classes)) ->
- let base = snd ppath ^ "$" in
- (List.map (fun (def,p) ->
- replace_canonical_name p (fst ppath) base (snd ppath ^ ".") def, p) classes) @ acc
- | _ -> acc);
- ) [] cls.cinner_types in
- (* add _Statics class *)
- let inner = try
- if not (List.mem JInterface cls.cflags) then raise Not_found;
- let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in
- let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in
- if not (smethods <> [] || sfields <> []) then raise Not_found;
- let obj = TObject( (["java";"lang"],"Object"), []) in
- let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in
- match ncls with
- | EClass c :: imports ->
- (EClass { c with d_name = c.d_name ^ "_Statics" }, pos) :: inner @ List.map (fun i -> i,pos) imports
- | _ -> assert false
- with | Not_found ->
- inner
- in
- let inner_alias = ref SS.empty in
- List.iter (fun x ->
- match fst x with
- | EClass c ->
- inner_alias := SS.add c.d_name !inner_alias;
- | _ -> ()
- ) inner;
- let alias_list = ref [] in
- List.iter (fun x ->
- match x with
- | (EClass c, pos) -> begin
- let parts = String.nsplit c.d_name "_24" in
- match parts with
- | _ :: _ ->
- let alias_name = String.concat "_" parts in
- if (not (SS.mem alias_name !inner_alias)) && (not (String.exists (snd path) "_24")) then begin
- let alias_def = ETypedef {
- d_name = alias_name;
- d_doc = None;
- d_params = c.d_params;
- d_meta = [];
- d_flags = [];
- d_data = CTPath {
- tpackage = pack;
- tname = snd path;
- tparams = List.map (fun tp ->
- TPType (CTPath {
- tpackage = [];
- tname = tp.tp_name;
- tparams = [];
- tsub = None;
- })
- ) c.d_params;
- tsub = Some(c.d_name);
- };
- } in
- inner_alias := SS.add alias_name !inner_alias;
- alias_list := (alias_def, pos) :: !alias_list;
- end
- | _ -> ()
- end
- | _ -> ()
- ) inner;
- let inner = List.concat [!alias_list ; inner] in
- let classes = List.map (fun t -> t,pos) (convert_java_class ctx pos cls) in
- let imports, defs = List.partition (function | (EImport(_),_) -> true | _ -> false) (classes @ inner) in
- let ret = Some ( real_path, (pack, imports @ defs) ) in
- ctx.jtparams <- old_types;
- ret
- end
- with
- | JReader.Error_message msg ->
- prerr_endline ("Class reader failed: " ^ msg);
- None
- | e ->
- if com.verbose then begin
- (* prerr_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *)
- prerr_endline (Printexc.to_string e)
- end;
- None
- in
- let build path p = build (create_ctx com) path p (ref [["java";"lang"], "String"]) in
- let cached_files = ref None in
- let list_all_files () = match !cached_files with
- | None ->
- let ret = list_all_files () in
- cached_files := Some ret;
- ret
- | Some r -> r
- in
- (* TODO: add_dependency m mdep *)
- com.load_extern_type <- com.load_extern_type @ [build];
- com.java_libs <- (file, std, close, list_all_files, get_raw_class) :: com.java_libs
|