12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674 |
- (*
- The Haxe Compiler
- Copyright (C) 2005-2015 Haxe Foundation
- This program is free software; you can redistribute it and/or
- modify it under the terms of the GNU General Public License
- as published by the Free Software Foundation; either version 2
- of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
- *)
- 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( _, 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 high_surrogate c = (c lsr 10) + 0xD7C0 in
- let low_surrogate c = (c land 0x3FF) lor 0xDC00 in
- let h = ref Int32.zero in
- let thirtyone = Int32.of_int 31 in
- (try
- UTF8.validate s;
- UTF8.iter (fun c ->
- let c = (UChar.code c) in
- if c > 0xFFFF then
- (h := Int32.add (Int32.mul thirtyone !h)
- (Int32.of_int (high_surrogate c));
- h := Int32.add (Int32.mul thirtyone !h)
- (Int32.of_int (low_surrogate c)))
- else
- h := Int32.add (Int32.mul thirtyone !h)
- (Int32.of_int c)
- ) s
- with UTF8.Malformed_code ->
- String.iter (fun c ->
- h := Int32.add (Int32.mul thirtyone !h)
- (Int32.of_int (Char.code c))) s
- );
- !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) *)
- TInst(cl,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({ cl_kind = KExpr _ }, _) -> t_dynamic
- | 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)) ->
- let changed_name = change_id ef.ef_name in
- write w changed_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.gtypes_list;
- 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 =
- Codegen.map_source_header gen.gcon (fun s -> print w "// %s\n" s);
- 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 && not (Meta.has Meta.Class e.e_meta) 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.gtypes_list;
- 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));*)
- let get_vmtype t = match real_type t with
- | TInst({ cl_path = ["java"],"NativeArray" }, tl) -> t
- | TInst(c,tl) -> TInst(c,List.map (fun _ -> t_dynamic) tl)
- | TEnum(e,tl) -> TEnum(e, List.map (fun _ -> t_dynamic) tl)
- | TType(t,tl) -> TType(t, List.map (fun _ -> t_dynamic) tl)
- | TAbstract(a,tl) -> TAbstract(a, List.map (fun _ -> t_dynamic) tl)
- | t -> t
- in
- FixOverrides.configure ~get_vmtype 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 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
- (* 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 cl_cl = get_cl (get_type gen (["java";"lang"],"Class")) in
- 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 "getClass" (TFun([], (TInst(cl_cl,[t_dynamic])))) 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;
- tp_meta = [];
- }
- 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);
- tp_meta = [];
- }
- | (name, None, impl) ->
- {
- tp_name = name;
- tp_params = [];
- tp_constraints = List.map (convert_signature ctx p) (impl);
- tp_meta = [];
- }
- ) 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" && not (String.exists f "$") ->
- (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" && not (String.exists file "$") 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
- let first = match !types with
- | [ ["java";"lang"], "String" ] | [] -> true
- | p :: _ ->
- false
- in
- 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), _ ->
- let is_disallowed_inner = first && String.exists (snd cls.cpath) "$" in
- let is_disallowed_inner = if is_disallowed_inner then begin
- let outer, inner = String.split (snd cls.cpath) "$" in
- match get_raw_class (fst path, outer) with
- | None -> false
- | _ -> true
- end else
- false
- in
- if is_disallowed_inner then
- None
- else begin
- 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
- 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
|