gencpp.ml 233 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850
  1. (*
  2. The Haxe Compiler
  3. Copyright (C) 2005-2016 Haxe Foundation
  4. This program is free software; you can redistribute it and/or
  5. modify it under the terms of the GNU General Public License
  6. as published by the Free Software Foundation; either version 2
  7. of the License, or (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  15. *)
  16. open Ast
  17. open Type
  18. open Common
  19. let unsupported p = error "This expression cannot be generated to Cpp" p
  20. (*
  21. Generators do not care about non-core-type abstracts, so let us follow them
  22. away by default.
  23. *)
  24. let follow = Abstract.follow_with_abstracts
  25. (*
  26. Code for generating source files.
  27. It manages creating diretories, indents, blocks and only modifying files
  28. when the content changes.
  29. *)
  30. (*
  31. A class_path is made from a package (array of strings) and a class name.
  32. Join these together, inclding a separator. eg, "/" for includes : pack1/pack2/Name or "::"
  33. for namespace "pack1::pack2::Name"
  34. *)
  35. let join_class_path path separator =
  36. let result = match fst path, snd path with
  37. | [], s -> s
  38. | el, s -> String.concat separator el ^ separator ^ s in
  39. if (String.contains result '+') then begin
  40. let idx = String.index result '+' in
  41. (String.sub result 0 idx) ^ (String.sub result (idx+1) ((String.length result) - idx -1 ) )
  42. end else
  43. result;;
  44. (* The internal classes are implemented by the core hxcpp system, so the cpp
  45. classes should not be generated *)
  46. let is_internal_class = function
  47. | ([],"Int") | ([],"Void") | ([],"String") | ([], "Null") | ([], "Float")
  48. | ([],"Array") | ([], "Class") | ([], "Enum") | ([], "Bool")
  49. | ([], "Dynamic") | ([], "ArrayAccess") | (["cpp"], "FastIterator")
  50. | (["cpp"],"Pointer") | (["cpp"],"ConstPointer")
  51. | (["cpp"],"RawPointer") | (["cpp"],"RawConstPointer")
  52. | (["cpp"],"Function") -> true
  53. | ([],"Math") | (["haxe";"io"], "Unsigned_char__") -> true
  54. | (["cpp"],"Int8") | (["cpp"],"UInt8") | (["cpp"],"Char")
  55. | (["cpp"],"Int16") | (["cpp"],"UInt16")
  56. | (["cpp"],"Int32") | (["cpp"],"UInt32")
  57. | (["cpp"],"Int64") | (["cpp"],"UInt64")
  58. | (["cpp"],"Float32") | (["cpp"],"Float64") -> true
  59. | _ -> false;;
  60. let get_include_prefix common_ctx with_slash =
  61. try
  62. (Common.defined_value common_ctx Define.IncludePrefix) ^ (if with_slash then "/" else "")
  63. with
  64. Not_found -> ""
  65. ;;
  66. let should_prefix_include = function
  67. | x when is_internal_class x -> false
  68. | ([],"hxMath") -> true
  69. | _ -> false;;
  70. class source_writer common_ctx write_func close_func =
  71. object(this)
  72. val indent_str = "\t"
  73. val mutable indent = ""
  74. val mutable indents = []
  75. val mutable just_finished_block = false
  76. method close = close_func(); ()
  77. method write x = write_func x; just_finished_block <- false
  78. method indent_one = this#write indent_str
  79. method push_indent = indents <- indent_str::indents; indent <- String.concat "" indents
  80. method pop_indent = match indents with
  81. | h::tail -> indents <- tail; indent <- String.concat "" indents
  82. | [] -> indent <- "/*?*/";
  83. method write_i x = this#write (indent ^ x)
  84. method get_indent = indent
  85. method begin_block = this#write ("{\n"); this#push_indent
  86. method end_block = this#pop_indent; this#write_i "}\n"; just_finished_block <- true
  87. method end_block_line = this#pop_indent; this#write_i "}"; just_finished_block <- true
  88. method terminate_line = this#write (if just_finished_block then "" else ";\n")
  89. method add_include class_path =
  90. ( match class_path with
  91. | (["@verbatim"],file) -> this#write ("#include \"" ^ file ^ "\"\n");
  92. | _ ->
  93. let prefix = if should_prefix_include class_path then "" else get_include_prefix common_ctx true in
  94. this#write ("#ifndef INCLUDED_" ^ (join_class_path class_path "_") ^ "\n");
  95. this#write ("#include <" ^ prefix ^ (join_class_path class_path "/") ^ ".h>\n");
  96. this#write ("#endif\n")
  97. )
  98. end;;
  99. let file_source_writer common_ctx filename =
  100. let out_file = open_out filename in
  101. new source_writer common_ctx (output_string out_file) (fun ()-> close_out out_file);;
  102. let read_whole_file chan =
  103. Std.input_all chan;;
  104. (* The cached_source_writer will not write to the file if it has not changed,
  105. thus allowing the makefile dependencies to work correctly *)
  106. let cached_source_writer common_ctx filename =
  107. try
  108. let in_file = open_in filename in
  109. let old_contents = read_whole_file in_file in
  110. close_in in_file;
  111. let buffer = Buffer.create 0 in
  112. let add_buf str = Buffer.add_string buffer str in
  113. let close = fun () ->
  114. let contents = Buffer.contents buffer in
  115. if (not (contents=old_contents) ) then begin
  116. let out_file = open_out filename in
  117. output_string out_file contents;
  118. close_out out_file;
  119. end;
  120. in
  121. new source_writer common_ctx (add_buf) (close);
  122. with _ ->
  123. file_source_writer common_ctx filename;;
  124. let make_class_directories = Common.mkdir_recursive;;
  125. let make_base_directory dir =
  126. make_class_directories "" ( ( Str.split_delim (Str.regexp "[\\/]+") dir ) );;
  127. let new_source_file common_ctx base_dir sub_dir extension class_path =
  128. let include_prefix = get_include_prefix common_ctx true in
  129. let full_dir =
  130. if (sub_dir="include") && (include_prefix<>"") then begin
  131. let dir = match fst class_path with
  132. | [] -> base_dir ^ "/include/" ^ (get_include_prefix common_ctx false)
  133. | path -> base_dir ^ "/include/" ^ include_prefix ^ ( String.concat "/" path )
  134. in
  135. make_base_directory dir;
  136. dir
  137. end else begin
  138. make_class_directories base_dir ( sub_dir :: (fst class_path));
  139. base_dir ^ "/" ^ sub_dir ^ "/" ^ ( String.concat "/" (fst class_path) )
  140. end
  141. in
  142. cached_source_writer common_ctx (full_dir ^ "/" ^ ((snd class_path) ^ extension));;
  143. let source_file_extension common_ctx =
  144. (* no need to -D file_extension if -D objc is defined *)
  145. if Common.defined common_ctx Define.Objc then
  146. ".mm"
  147. else try
  148. "." ^ (Common.defined_value common_ctx Define.FileExtension)
  149. with
  150. Not_found -> ".cpp"
  151. ;;
  152. let new_cpp_file common_ctx base_dir = new_source_file common_ctx base_dir "src" (source_file_extension common_ctx);;
  153. let new_header_file common_ctx base_dir =
  154. new_source_file common_ctx base_dir "include" ".h";;
  155. (* CPP code generation context *)
  156. type context =
  157. {
  158. mutable ctx_common : Common.context;
  159. mutable ctx_output : string -> unit;
  160. mutable ctx_dbgout : string -> unit;
  161. mutable ctx_writer : source_writer;
  162. mutable ctx_calling : bool;
  163. mutable ctx_assigning : bool;
  164. mutable ctx_return_from_block : bool;
  165. mutable ctx_tcall_expand_args : bool;
  166. (* This is for returning from the child nodes of TMatch, TSwitch && TTry *)
  167. mutable ctx_return_from_internal_node : bool;
  168. mutable ctx_debug_level : int;
  169. mutable ctx_real_this_ptr : bool;
  170. mutable ctx_real_void : bool;
  171. mutable ctx_dynamic_this_ptr : bool;
  172. mutable ctx_dump_src_pos : unit -> unit;
  173. mutable ctx_static_id_curr : int;
  174. mutable ctx_static_id_used : int;
  175. mutable ctx_static_id_depth : int;
  176. mutable ctx_switch_id : int;
  177. mutable ctx_class_name : string;
  178. mutable ctx_class_super_name : string;
  179. mutable ctx_local_function_args : (string,string) Hashtbl.t;
  180. mutable ctx_local_return_block_args : (string,string) Hashtbl.t;
  181. mutable ctx_class_member_types : (string,string) Hashtbl.t;
  182. mutable ctx_file_info : (string,string) PMap.t ref;
  183. mutable ctx_for_extern : bool;
  184. }
  185. let new_context common_ctx writer debug file_info =
  186. {
  187. ctx_common = common_ctx;
  188. ctx_writer = writer;
  189. ctx_output = (writer#write);
  190. ctx_dbgout = if debug>1 then (writer#write) else (fun _ -> ());
  191. ctx_calling = false;
  192. ctx_assigning = false;
  193. ctx_debug_level = debug;
  194. ctx_dump_src_pos = (fun() -> ());
  195. ctx_return_from_block = false;
  196. ctx_tcall_expand_args = false;
  197. ctx_return_from_internal_node = false;
  198. ctx_real_this_ptr = true;
  199. ctx_real_void = false;
  200. ctx_dynamic_this_ptr = false;
  201. ctx_static_id_curr = 0;
  202. ctx_static_id_used = 0;
  203. ctx_static_id_depth = 0;
  204. ctx_switch_id = 0;
  205. ctx_class_name = "";
  206. ctx_class_super_name = "";
  207. ctx_local_function_args = Hashtbl.create 0;
  208. ctx_local_return_block_args = Hashtbl.create 0;
  209. ctx_class_member_types = Hashtbl.create 0;
  210. ctx_file_info = file_info;
  211. ctx_for_extern = false;
  212. }
  213. let new_extern_context common_ctx writer debug file_info =
  214. let ctx = new_context common_ctx writer debug file_info in
  215. ctx.ctx_for_extern <- true;
  216. ctx
  217. ;;
  218. (* The internal header files are also defined in the hx/Object.h file, so you do
  219. #include them separately. However, Math classes has its
  220. own header file (under the hxcpp tree) so these should be included *)
  221. let include_class_header = function
  222. | ([],"@Main") -> false
  223. | ([],"Math") -> true
  224. | path -> not ( is_internal_class path )
  225. let is_cpp_class = function
  226. | ("cpp"::_ , _) -> true
  227. | ( [] , "EReg" ) -> true
  228. | ( ["haxe"] , "Log" ) -> true
  229. | _ -> false;;
  230. let is_scalar typename = match typename with
  231. | "int" | "unsigned int" | "signed int"
  232. | "char" | "unsigned char"
  233. | "short" | "unsigned short"
  234. | "float" | "double"
  235. | "bool" -> true
  236. | _ -> false
  237. ;;
  238. let is_block exp = match exp.eexpr with | TBlock _ -> true | _ -> false ;;
  239. (* todo - is this how it's done? *)
  240. let hash_keys hash =
  241. let key_list = ref [] in
  242. Hashtbl.iter (fun key value -> key_list := key :: !key_list ) hash;
  243. !key_list;;
  244. let pmap_keys pmap =
  245. let key_list = ref [] in
  246. PMap.iter (fun key _ -> key_list := key :: !key_list ) pmap;
  247. !key_list;;
  248. let pmap_values pmap =
  249. let value_list = ref [] in
  250. PMap.iter (fun _ value -> value_list := value :: !value_list ) pmap;
  251. !value_list;;
  252. (* The Hashtbl structure seems a little odd - but here is a helper function *)
  253. let hash_iterate hash visitor =
  254. let result = ref [] in
  255. Hashtbl.iter (fun key value -> result := (visitor key value) :: !result ) hash;
  256. !result
  257. (* Convert function names that can't be written in c++ ... *)
  258. let keyword_remap name =
  259. match name with
  260. | "__get" | "__set" | "__unsafe_get" | "__unsafe_set" | "__global__"
  261. | "__SetSize" | "__s" | "__trace" -> name
  262. (* | _ when (String.length name > 1) && (String.sub name 0 2 = "__") -> "_hx" ^ name *)
  263. | "int"
  264. | "auto" | "char" | "const" | "delete" | "double" | "Float" | "enum"
  265. | "extern" | "float" | "friend" | "goto" | "long" | "operator" | "protected"
  266. | "register" | "short" | "signed" | "sizeof" | "template" | "typedef"
  267. | "union" | "unsigned" | "void" | "volatile" | "or" | "and" | "xor" | "or_eq" | "not"
  268. | "and_eq" | "xor_eq" | "typeof" | "stdin" | "stdout" | "stderr" | "system"
  269. | "BIG_ENDIAN" | "LITTLE_ENDIAN" | "assert" | "NULL" | "wchar_t" | "EOF"
  270. | "bool" | "const_cast" | "dynamic_cast" | "explicit" | "export" | "mutable" | "namespace"
  271. | "reinterpret_cast" | "static_cast" | "typeid" | "typename" | "virtual"
  272. | "_Complex" | "INFINITY" | "NAN"
  273. | "INT_MIN" | "INT_MAX" | "INT8_MIN" | "INT8_MAX" | "UINT8_MAX" | "INT16_MIN"
  274. | "INT16_MAX" | "UINT16_MAX" | "INT32_MIN" | "INT32_MAX" | "UINT32_MAX"
  275. | "asm"
  276. | "abstract" | "decltype" | "finally" | "nullptr" | "static_assert"
  277. | "struct" -> "_hx_" ^ name
  278. | x -> x
  279. ;;
  280. let remap_class_path class_path =
  281. (List.map keyword_remap (fst class_path)) , (snd class_path)
  282. ;;
  283. let join_class_path_remap path separator =
  284. match join_class_path (remap_class_path path) separator with
  285. | "Class" -> "hx::Class"
  286. | x -> x
  287. ;;
  288. let get_meta_string meta key =
  289. let rec loop = function
  290. | [] -> ""
  291. | (k,[Ast.EConst (Ast.String name),_],_) :: _ when k=key-> name
  292. | _ :: l -> loop l
  293. in
  294. loop meta
  295. ;;
  296. let get_meta_string_path meta key =
  297. let rec loop = function
  298. | [] -> ""
  299. | (k,[Ast.EConst (Ast.String name),_], pos) :: _ when k=key->
  300. (try
  301. if (String.sub name 0 2) = "./" then begin
  302. let base = if (Filename.is_relative pos.pfile) then
  303. Filename.concat (Sys.getcwd()) pos.pfile
  304. else
  305. pos.pfile
  306. in
  307. Gencommon.normalize (Filename.concat (Filename.dirname base) (String.sub name 2 ((String.length name) -2) ))
  308. end else
  309. name
  310. with Invalid_argument _ -> name)
  311. | _ :: l -> loop l
  312. in
  313. loop meta
  314. ;;
  315. let get_meta_string_full_filename meta key =
  316. let rec loop = function
  317. | [] -> ""
  318. | (k,_, pos) :: _ when k=key->
  319. if (Filename.is_relative pos.pfile) then
  320. Gencommon.normalize (Filename.concat (Sys.getcwd()) pos.pfile)
  321. else
  322. pos.pfile
  323. | _ :: l -> loop l
  324. in
  325. loop meta
  326. ;;
  327. let get_meta_string_full_dirname meta key =
  328. let name = get_meta_string_full_filename meta key in
  329. try
  330. Gencommon.normalize (Filename.dirname name)
  331. with Invalid_argument _ -> ""
  332. ;;
  333. let get_field_access_meta field_access key =
  334. match field_access with
  335. | FInstance(_,_,class_field)
  336. | FStatic(_,class_field) -> get_meta_string class_field.cf_meta key
  337. | _ -> ""
  338. ;;
  339. let format_code code =
  340. String.concat "\n" (ExtString.String.nsplit code "\r\n")
  341. let get_code meta key =
  342. let code = get_meta_string meta key in
  343. let magic_var = "${GENCPP_SOURCE_DIRECTORY}" in
  344. let code = if ExtString.String.exists code magic_var then begin
  345. let source_directory = get_meta_string_full_dirname meta key in
  346. let _,code = ExtString.String.replace code magic_var source_directory in
  347. code
  348. end else
  349. code
  350. in
  351. if (code<>"") then format_code code ^ "\n" else code
  352. ;;
  353. let has_meta_key meta key =
  354. List.exists (fun m -> match m with | (k,_,_) when k=key-> true | _ -> false ) meta
  355. ;;
  356. let type_has_meta_key haxe_type key =
  357. match follow haxe_type with
  358. | TInst (klass,_) -> has_meta_key klass.cl_meta key
  359. | TType (type_def,_) -> has_meta_key type_def.t_meta key
  360. | TEnum (enum_def,_) -> has_meta_key enum_def.e_meta key
  361. | _ -> false
  362. ;;
  363. (*
  364. let dump_meta meta =
  365. List.iter (fun m -> match m with | (k,_,_) -> print_endline ((fst (MetaInfo.to_string k)) ^ "=" ^ (get_meta_string meta k) ) | _ -> () ) meta;;
  366. *)
  367. let get_class_code class_def key = match class_def.cl_kind with
  368. | KAbstractImpl abstract_def ->
  369. let value = (get_code abstract_def.a_meta key) in
  370. value
  371. | _ -> get_code class_def.cl_meta key
  372. ;;
  373. (* Add include to source code *)
  374. let add_include writer class_path =
  375. writer#add_include class_path;;
  376. (* This gets the class include order correct. In the header files, we forward declare
  377. the class types so the header file does not have any undefined variables.
  378. In the cpp files, we include all the required header files, providing the actual
  379. types for everything. This way there is no problem with circular class references.
  380. *)
  381. let gen_forward_decl writer class_path =
  382. begin
  383. let output = writer#write in
  384. match class_path with
  385. | (["@verbatim"],file) -> writer#write ("#include <" ^ file ^ ">\n");
  386. | _ ->
  387. let name = fst (remap_class_path class_path) in
  388. output ("HX_DECLARE_CLASS" ^ (string_of_int (List.length name ) ) ^ "(");
  389. List.iter (fun package_part -> output (package_part ^ ",") ) name;
  390. output ( (snd class_path) ^ ")\n")
  391. end;;
  392. let real_interfaces =
  393. List.filter (function (t,pl) ->
  394. match t, pl with
  395. | { cl_path = ["cpp";"rtti"],_ },[] -> false
  396. | _ -> true
  397. );;
  398. let rec is_function_expr expr =
  399. match expr.eexpr with
  400. | TParenthesis expr | TMeta(_,expr) -> is_function_expr expr
  401. | TFunction _ -> true
  402. | _ -> false;;
  403. let is_var_field field =
  404. match field.cf_kind with
  405. | Var _ -> true
  406. | Method MethDynamic -> true
  407. | _ -> false
  408. ;;
  409. let rec has_rtti_interface c interface =
  410. List.exists (function (t,pl) ->
  411. (snd t.cl_path) = interface && (match fst t.cl_path with | ["cpp";"rtti"] -> true | _ -> false )
  412. ) c.cl_implements ||
  413. (match c.cl_super with None -> false | Some (c,_) -> has_rtti_interface c interface);;
  414. let has_field_integer_lookup class_def =
  415. has_rtti_interface class_def "FieldIntegerLookup";;
  416. let has_field_integer_numeric_lookup class_def =
  417. has_rtti_interface class_def "FieldNumericIntegerLookup";;
  418. (* Output required code to place contents in required namespace *)
  419. let gen_open_namespace output class_path =
  420. List.iter (fun namespace -> output ("namespace " ^ namespace ^ "{\n")) (List.map keyword_remap (fst class_path));;
  421. let gen_close_namespace output class_path =
  422. List.iter
  423. (fun namespace -> output ( "}" ^ " // end namespace " ^ namespace ^"\n"))
  424. (fst class_path);;
  425. (* The basic types can have default values and are passesby value *)
  426. let is_numeric = function
  427. | "Int" | "Bool" | "Float" | "::haxe::io::Unsigned_char__" | "unsigned char" -> true
  428. | "::cpp::UInt8" | "::cpp::Int8" | "::cpp::Char"
  429. | "::cpp::UInt16" | "::cpp::Int16"
  430. | "::cpp::UInt32" | "::cpp::Int32"
  431. | "::cpp::UInt64" | "::cpp::Int64"
  432. | "::cpp::Float32" | "::cpp::Float64"
  433. | "int" | "bool" | "double" | "float" -> true
  434. | _ -> false
  435. let rec remove_parens expression =
  436. match expression.eexpr with
  437. | TParenthesis e -> remove_parens e
  438. | TMeta(_,e) -> remove_parens e
  439. | _ -> expression
  440. ;;
  441. (*
  442. let rec remove_parens_cast expression =
  443. match expression.eexpr with
  444. | TParenthesis e -> remove_parens_cast e
  445. | TMeta(_,e) -> remove_parens_cast e
  446. | TCast ( e,None) -> remove_parens_cast e
  447. | _ -> expression
  448. ;;
  449. *)
  450. let is_interface_type t =
  451. match follow t with
  452. | TInst (klass,params) -> klass.cl_interface
  453. | _ -> false
  454. ;;
  455. let is_cpp_function_instance haxe_type =
  456. match follow haxe_type with
  457. | TInst (klass,params) ->
  458. (match klass.cl_path with
  459. | ["cpp"] , "Function" -> true
  460. | _ -> false )
  461. | _ -> false
  462. ;;
  463. let is_cpp_function_class haxe_type =
  464. match follow haxe_type with
  465. | TType (klass,params) ->
  466. (match klass.t_path with
  467. | ["cpp"] , "Function" -> true
  468. | _ -> false )
  469. | _ -> false
  470. ;;
  471. let is_fromStaticFunction_call func =
  472. match (remove_parens func).eexpr with
  473. | TField (_,FStatic ({cl_path=["cpp"],"Function"},{cf_name="fromStaticFunction"} ) ) -> true
  474. | _ -> false
  475. ;;
  476. let is_objc_call field =
  477. match field with
  478. | FStatic(cl,_) | FInstance(cl,_,_) ->
  479. cl.cl_extern && Meta.has Meta.Objc cl.cl_meta
  480. | _ -> false
  481. ;;
  482. let is_objc_type t = match follow t with
  483. | TInst(cl,_) -> cl.cl_extern && Meta.has Meta.Objc cl.cl_meta
  484. | _ -> false
  485. ;;
  486. let is_addressOf_call func =
  487. match (remove_parens func).eexpr with
  488. | TField (_,FStatic ({cl_path=["cpp"],"Pointer"},{cf_name="addressOf"} ) ) -> true
  489. | _ -> false
  490. ;;
  491. let is_lvalue var =
  492. match (remove_parens var).eexpr with
  493. | TLocal _ -> true
  494. | TField (_,FStatic(_,field) ) | TField (_,FInstance(_,_,field) ) -> is_var_field field
  495. | _ -> false
  496. ;;
  497. let is_pointer haxe_type includeRaw =
  498. match follow haxe_type with
  499. | TInst (klass,params) ->
  500. (match klass.cl_path with
  501. | ["cpp"] , "Pointer"
  502. | ["cpp"] , "ConstPointer"
  503. | ["cpp"] , "Function" -> true
  504. | ["cpp"] , "RawPointer" when includeRaw -> true
  505. | ["cpp"] , "RawConstPointer" when includeRaw -> true
  506. | _ -> false )
  507. | TType (type_def,params) ->
  508. (match type_def.t_path with
  509. | ["cpp"] , "Pointer"
  510. | ["cpp"] , "ConstPointer"
  511. | ["cpp"] , "Function" -> true
  512. | ["cpp"] , "RawPointer" when includeRaw -> true
  513. | ["cpp"] , "RawConstPointer" when includeRaw -> true
  514. | _ -> false )
  515. | _ -> false
  516. ;;
  517. let is_dynamic_type_param class_kind =
  518. match class_kind with
  519. | KTypeParameter _ -> true
  520. | _ -> false
  521. ;;
  522. (* Get a string to represent a type.
  523. The "suffix" will be nothing or "_obj", depending if we want the name of the
  524. pointer class or the pointee (_obj class *)
  525. let rec class_string klass suffix params remap =
  526. let type_string = type_string_remap remap in
  527. let join_class_path_remap = if remap then join_class_path_remap else join_class_path in
  528. (match klass.cl_path with
  529. (* Array class *)
  530. | ([],"Array") when is_dynamic_array_param (List.hd params) ->
  531. "cpp::ArrayBase" ^ suffix (* "Dynamic" *)
  532. | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "< " ^ (String.concat ","
  533. (List.map array_element_type params) ) ^ " >"
  534. (* FastIterator class *)
  535. | (["cpp"],"FastIterator") -> "::cpp::FastIterator" ^ suffix ^ "< " ^ (String.concat ","
  536. (List.map type_string params) ) ^ " >"
  537. | (["cpp"],"Pointer")
  538. | (["cpp"],"ConstPointer") ->
  539. "::cpp::Pointer< " ^ (String.concat "," (List.map type_string params) ) ^ " >"
  540. | (["cpp"],"RawPointer") ->
  541. " " ^ (String.concat "," (List.map type_string params) ) ^ " * "
  542. | (["cpp"],"RawConstPointer") ->
  543. " const " ^ (String.concat "," (List.map type_string params) ) ^ " * "
  544. | (["cpp"],"Function") ->
  545. "::cpp::Function< " ^ (cpp_function_signature_params params) ^ " >"
  546. | _ when is_dynamic_type_param klass.cl_kind -> "Dynamic"
  547. | ([],"#Int") -> "/* # */int"
  548. | (["haxe";"io"],"Unsigned_char__") -> "unsigned char"
  549. | ([],"Class") -> "hx::Class"
  550. | ([],"EnumValue") -> "Dynamic"
  551. | ([],"Null") -> (match params with
  552. | [t] ->
  553. (match follow t with
  554. | TAbstract ({ a_path = [],"Int" },_)
  555. | TAbstract ({ a_path = [],"Float" },_)
  556. | TAbstract ({ a_path = [],"Bool" },_)
  557. | TInst ({ cl_path = [],"Int" },_)
  558. | TInst ({ cl_path = [],"Float" },_)
  559. | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic"
  560. | t when type_has_meta_key t Meta.NotNull -> "Dynamic"
  561. | _ -> "/*NULL*/" ^ (type_string t) )
  562. | _ -> assert false);
  563. (* Objective-C class *)
  564. | path when is_objc_type (TInst(klass,[])) ->
  565. let str = join_class_path_remap klass.cl_path "::" in
  566. if suffix = "_obj" then
  567. str
  568. else if klass.cl_interface then
  569. "id <" ^ str ^ ">"
  570. else
  571. str ^ " *"
  572. (* Normal class *)
  573. | path when klass.cl_extern && (not (is_internal_class path) )->
  574. (join_class_path_remap klass.cl_path "::") ^ suffix
  575. | _ -> "::" ^ (join_class_path_remap klass.cl_path "::") ^ suffix
  576. )
  577. and type_string_suff suffix haxe_type remap =
  578. let type_string = type_string_remap remap in
  579. let join_class_path_remap = if remap then join_class_path_remap else join_class_path in
  580. (match haxe_type with
  581. | TMono r -> (match !r with None -> "Dynamic" ^ suffix | Some t -> type_string_suff suffix t remap)
  582. | TAbstract ({ a_path = ([],"Void") },[]) -> "Void"
  583. | TAbstract ({ a_path = ([],"Bool") },[]) -> "bool"
  584. | TAbstract ({ a_path = ([],"Float") },[]) -> "Float"
  585. | TAbstract ({ a_path = ([],"Int") },[]) -> "int"
  586. | TAbstract( { a_path = ([], "EnumValue") }, _ ) -> "Dynamic"
  587. | TEnum (enum,params) -> "::" ^ (join_class_path_remap enum.e_path "::") ^ suffix
  588. | TInst (klass,params) -> (class_string klass suffix params remap)
  589. | TType (type_def,params) ->
  590. (match type_def.t_path with
  591. | [] , "Null" ->
  592. (match params with
  593. | [t] ->
  594. (match follow t with
  595. | TAbstract ({ a_path = [],"Int" },_)
  596. | TAbstract ({ a_path = [],"Float" },_)
  597. | TAbstract ({ a_path = [],"Bool" },_)
  598. | TInst ({ cl_path = [],"Int" },_)
  599. | TInst ({ cl_path = [],"Float" },_)
  600. | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" ^ suffix
  601. | t when type_has_meta_key t Meta.NotNull -> "Dynamic" ^ suffix
  602. | _ -> type_string_suff suffix t remap)
  603. | _ -> assert false);
  604. | [] , "Array" ->
  605. (match params with
  606. | [t] when (type_string (follow t) ) = "Dynamic" -> "Dynamic"
  607. | [t] -> "Array< " ^ (type_string (follow t) ) ^ " >"
  608. | _ -> assert false)
  609. | ["cpp"] , "FastIterator" ->
  610. (match params with
  611. | [t] -> "::cpp::FastIterator< " ^ (type_string (follow t) ) ^ " >"
  612. | _ -> assert false)
  613. | ["cpp"] , "Pointer"
  614. | ["cpp"] , "ConstPointer" ->
  615. (match params with
  616. | [t] -> "::cpp::Pointer< " ^ (type_string (follow t) ) ^ " >"
  617. | _ -> assert false)
  618. | ["cpp"] , "RawPointer" ->
  619. (match params with
  620. | [t] -> " " ^ (type_string (follow t) ) ^ " *"
  621. | _ -> assert false)
  622. | ["cpp"] , "RawConstPointer" ->
  623. (match params with
  624. | [t] -> "const " ^ (type_string (follow t) ) ^ " *"
  625. | _ -> assert false)
  626. | ["cpp"] , "Function" ->
  627. "::cpp::Function< " ^ (cpp_function_signature_params params ) ^ " >"
  628. | _ -> type_string_suff suffix (apply_params type_def.t_params params type_def.t_type) remap
  629. )
  630. | TFun (args,haxe_type) -> "Dynamic" ^ suffix
  631. | TAnon a -> "Dynamic"
  632. (*
  633. (match !(a.a_status) with
  634. | Statics c -> type_string_suff suffix (TInst (c,List.map snd c.cl_params))
  635. | EnumStatics e -> type_string_suff suffix (TEnum (e,List.map snd e.e_params))
  636. | _ -> "Dynamic" ^ suffix )
  637. *)
  638. | TDynamic haxe_type -> "Dynamic" ^ suffix
  639. | TLazy func -> type_string_suff suffix ((!func)()) remap
  640. | TAbstract (abs,pl) when abs.a_impl <> None ->
  641. type_string_suff suffix (Abstract.get_underlying_type abs pl) remap
  642. | TAbstract (abs,pl) ->
  643. "::" ^ (join_class_path_remap abs.a_path "::") ^ suffix
  644. )
  645. and type_string_remap remap haxe_type =
  646. type_string_suff "" haxe_type remap
  647. and type_string haxe_type =
  648. type_string_suff "" haxe_type true
  649. and array_element_type haxe_type =
  650. match type_string haxe_type with
  651. | x when cant_be_null haxe_type -> x
  652. | x when is_interface_type (follow haxe_type) -> x
  653. | "::String" -> "::String"
  654. | _ -> "::Dynamic"
  655. and is_dynamic_array_param haxe_type =
  656. if (type_string (follow haxe_type)) = "Dynamic" then true
  657. else (match follow haxe_type with
  658. | TInst (klass,params) ->
  659. (match klass.cl_path with
  660. | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator")
  661. | (["cpp"],"RawPointer") |(["cpp"],"ConstRawPointer")
  662. | (["cpp"],"Pointer") |(["cpp"],"ConstPointer")|(["cpp"],"Function") -> false
  663. | _ -> (match klass.cl_kind with KTypeParameter _ -> true | _ -> false)
  664. )
  665. | _ -> false
  666. )
  667. and cpp_function_signature tfun abi =
  668. match follow tfun with
  669. | TFun(args,ret) -> (type_string ret) ^ " " ^ abi ^ "(" ^ (gen_tfun_interface_arg_list args) ^ ")"
  670. | _ -> "void *"
  671. and cpp_function_signature_params params = match params with
  672. | [t; abi] -> (match follow abi with
  673. | TInst (klass,_) -> cpp_function_signature t (get_meta_string klass.cl_meta Meta.Abi)
  674. | _ -> print_endline (type_string abi);
  675. assert false )
  676. | _ ->
  677. print_endline ("Params:" ^ (String.concat "," (List.map type_string params) ));
  678. assert false;
  679. and gen_interface_arg_type_name name opt typ =
  680. let type_str = (type_string typ) in
  681. (* type_str may have already converted Null<X> to Dynamic because of NotNull tag ... *)
  682. (if (opt && (cant_be_null typ) && type_str<>"Dynamic" ) then
  683. "hx::Null< " ^ type_str ^ " > "
  684. else
  685. type_str )
  686. ^ " " ^ (keyword_remap name)
  687. and gen_tfun_interface_arg_list args =
  688. String.concat "," (List.map (fun (name,opt,typ) -> gen_interface_arg_type_name name opt typ) args)
  689. and cant_be_null haxe_type =
  690. is_numeric (type_string haxe_type) || (type_has_meta_key haxe_type Meta.NotNull )
  691. ;;
  692. let is_object type_string =
  693. not (is_numeric type_string || type_string="::String");
  694. ;;
  695. let is_array haxe_type =
  696. match follow haxe_type with
  697. | TInst (klass,params) ->
  698. (match klass.cl_path with
  699. | [] , "Array" -> not (is_dynamic_array_param (List.hd params))
  700. | _ -> false )
  701. | TType (type_def,params) ->
  702. (match type_def.t_path with
  703. | [] , "Array" -> not (is_dynamic_array_param (List.hd params))
  704. | _ -> false )
  705. | _ -> false
  706. ;;
  707. let is_array_or_dyn_array haxe_type =
  708. match follow haxe_type with
  709. | TInst (klass,params) ->
  710. (match klass.cl_path with | [] , "Array" -> true | _ -> false )
  711. | TType (type_def,params) ->
  712. (match type_def.t_path with | [] , "Array" -> true | _ -> false )
  713. | _ -> false
  714. ;;
  715. let is_array_implementer haxe_type =
  716. match follow haxe_type with
  717. | TInst (klass,params) ->
  718. (match klass.cl_array_access with
  719. | Some _ -> true
  720. | _ -> false )
  721. | _ -> false
  722. ;;
  723. let is_numeric_field field =
  724. match field.cf_kind with
  725. | Var _ -> is_numeric (type_string field.cf_type)
  726. | _ -> false;
  727. ;;
  728. let is_static_access obj =
  729. match (remove_parens obj).eexpr with
  730. | TTypeExpr _ -> true
  731. | _ -> false
  732. ;;
  733. let is_native_with_space func =
  734. match (remove_parens func).eexpr with
  735. | TField(obj,field) when is_static_access obj ->
  736. String.contains (get_field_access_meta field Meta.Native) ' '
  737. | _ -> false
  738. ;;
  739. let rec is_cpp_function_member func =
  740. match (remove_parens func).eexpr with
  741. | TField(obj,field) when is_cpp_function_instance obj.etype -> true
  742. | TCall(obj,_) -> is_cpp_function_member obj
  743. | _ -> false
  744. ;;
  745. (* Get the type and output it to the stream *)
  746. let gen_type ctx haxe_type =
  747. ctx.ctx_output (type_string haxe_type)
  748. ;;
  749. let member_type ctx field_object member =
  750. let name = (if (is_array field_object.etype) then "::Array"
  751. else (type_string field_object.etype)) ^ "." ^ member in
  752. try ( Hashtbl.find ctx.ctx_class_member_types name )
  753. with Not_found -> "?";;
  754. let is_interface obj = is_interface_type obj.etype;;
  755. let should_implement_field x = not (is_extern_field x);;
  756. let is_function_member expression =
  757. match (follow expression.etype) with | TFun (_,_) -> true | _ -> false;;
  758. let is_internal_member member =
  759. match member with
  760. | "__Field" | "__IField" | "__Run" | "__Is" | "__GetClass" | "__GetType" | "__ToString"
  761. | "__s" | "__GetPtr" | "__SetField" | "__length" | "__IsArray" | "__SetThis" | "__Internal"
  762. | "__EnumParams" | "__Index" | "__Tag" | "__GetFields" | "toString" | "__HasField"
  763. | "__GetRealObject"
  764. -> true
  765. | _ -> false;;
  766. let is_extern_class class_def =
  767. class_def.cl_extern || (has_meta_key class_def.cl_meta Meta.Extern) ||
  768. (match class_def.cl_kind with
  769. | KAbstractImpl abstract_def -> (has_meta_key abstract_def.a_meta Meta.Extern)
  770. | _ -> false );
  771. ;;
  772. let is_native_gen_class class_def =
  773. (has_meta_key class_def.cl_meta Meta.NativeGen) ||
  774. (match class_def.cl_kind with
  775. | KAbstractImpl abstract_def -> (has_meta_key abstract_def.a_meta Meta.NativeGen)
  776. | _ -> false );
  777. ;;
  778. let is_extern_class_instance obj =
  779. match follow obj.etype with
  780. | TInst (klass,params) -> klass.cl_extern
  781. | _ -> false
  782. ;;
  783. let is_struct_access t =
  784. match follow t with
  785. | TInst (class_def,_) -> (has_meta_key class_def.cl_meta Meta.StructAccess)
  786. | _ -> false
  787. ;;
  788. let rec is_dynamic_accessor name acc field class_def =
  789. ( ( acc ^ "_" ^ field.cf_name) = name ) &&
  790. ( not (List.exists (fun f -> f.cf_name=name) class_def.cl_ordered_fields) )
  791. && (match class_def.cl_super with None -> true | Some (parent,_) -> is_dynamic_accessor name acc field parent )
  792. ;;
  793. let gen_arg_type_name name default_val arg_type prefix =
  794. let remap_name = keyword_remap name in
  795. let type_str = (type_string arg_type) in
  796. match default_val with
  797. | Some TNull -> (type_str,remap_name)
  798. | Some constant when (cant_be_null arg_type) -> ("hx::Null< " ^ type_str ^ " > ",prefix ^ remap_name)
  799. | Some constant -> (type_str,prefix ^ remap_name)
  800. | _ -> (type_str,remap_name);;
  801. (* Generate prototype text, including allowing default values to be null *)
  802. let gen_arg name default_val arg_type prefix =
  803. let pair = gen_arg_type_name name default_val arg_type prefix in
  804. (fst pair) ^ " " ^ (snd pair);;
  805. let rec gen_arg_list arg_list prefix =
  806. String.concat "," (List.map (fun (v,o) -> (gen_arg v.v_name o v.v_type prefix) ) arg_list)
  807. let rec gen_tfun_arg_list arg_list =
  808. match arg_list with
  809. | [] -> ""
  810. | [(name,o,arg_type)] -> gen_arg name None arg_type ""
  811. | (name,o,arg_type) :: remaining ->
  812. (gen_arg name None arg_type "") ^ "," ^ (gen_tfun_arg_list remaining)
  813. (* Check to see if we are the first object in the parent tree to implement a dynamic interface *)
  814. let implement_dynamic_here class_def =
  815. let implements_dynamic c = match c.cl_dynamic with None -> false | _ -> true in
  816. let rec super_implements_dynamic c = match c.cl_super with
  817. | None -> false
  818. | Some (csup, _) -> if (implements_dynamic csup) then true else
  819. super_implements_dynamic csup;
  820. in
  821. ( (implements_dynamic class_def) && (not (super_implements_dynamic class_def) ) );;
  822. let gen_hash32 seed str =
  823. let h = ref (Int32.of_int seed) in
  824. let cycle = Int32.of_int 223 in
  825. for i = 0 to String.length str - 1 do
  826. h := Int32.add (Int32.mul !h cycle) (Int32.of_int (int_of_char (String.unsafe_get str i)));
  827. done;
  828. !h
  829. ;;
  830. let gen_hash seed str =
  831. Printf.sprintf "0x%08lx" (gen_hash32 seed str)
  832. ;;
  833. let gen_string_hash str =
  834. let h = gen_hash32 0 str in
  835. Printf.sprintf "\"\\x%02lx\",\"\\x%02lx\",\"\\x%02lx\",\"\\x%02lx\""
  836. (Int32.shift_right_logical (Int32.shift_left h 24) 24)
  837. (Int32.shift_right_logical (Int32.shift_left h 16) 24)
  838. (Int32.shift_right_logical (Int32.shift_left h 8) 24)
  839. (Int32.shift_right_logical h 24)
  840. ;;
  841. (* Make string printable for c++ code *)
  842. (* Here we know there are no utf8 characters, so use the L"" notation to avoid conversion *)
  843. let escape_stringw s l =
  844. let b = Buffer.create 0 in
  845. Buffer.add_char b 'L';
  846. Buffer.add_char b '"';
  847. let skip = ref 0 in
  848. for i = 0 to String.length s - 1 do
  849. if (!skip>0) then begin
  850. skip := !skip -1;
  851. l := !l-1;
  852. end else
  853. match Char.code (String.unsafe_get s i) with
  854. | c when (c>127) ->
  855. let encoded = ((c land 0x3F) lsl 6) lor ( Char.code ((String.unsafe_get s (i+1))) land 0x7F) in
  856. skip := 1;
  857. Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" encoded)
  858. | c when (c < 32) -> Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" c)
  859. | c -> Buffer.add_char b (Char.chr c)
  860. done;
  861. Buffer.add_char b '"';
  862. Buffer.contents b;;
  863. let special_to_hex s =
  864. let l = String.length s in
  865. let b = Buffer.create 0 in
  866. for i = 0 to l - 1 do
  867. match Char.code (String.unsafe_get s i) with
  868. | c when (c>127) || (c<32) ->
  869. Buffer.add_string b (Printf.sprintf "\\x%02x\"\"" c)
  870. | c -> Buffer.add_char b (Char.chr c)
  871. done;
  872. Buffer.contents b;;
  873. let escape_extern s =
  874. let l = String.length s in
  875. let b = Buffer.create 0 in
  876. for i = 0 to l - 1 do
  877. match Char.code (String.unsafe_get s i) with
  878. | c when (c>127) || (c<32) || (c=34) || (c=92) ->
  879. Buffer.add_string b (Printf.sprintf "\\x%02x" c)
  880. | c -> Buffer.add_char b (Char.chr c)
  881. done;
  882. Buffer.contents b;;
  883. let has_utf8_chars s =
  884. let result = ref false in
  885. for i = 0 to String.length s - 1 do
  886. result := !result || ( Char.code (String.unsafe_get s i) > 127 )
  887. done;
  888. !result;;
  889. let escape_command s =
  890. let b = Buffer.create 0 in
  891. String.iter (fun ch -> if (ch=='"' || ch=='\\' ) then Buffer.add_string b "\\"; Buffer.add_char b ch ) s;
  892. Buffer.contents b;;
  893. let str s =
  894. let rec split s plus =
  895. let escaped = Ast.s_escape ~hex:false s in
  896. let hexed = (special_to_hex escaped) in
  897. if (String.length hexed <= 16000 ) then
  898. plus ^ " HX_CSTRING(\"" ^ hexed ^ "\")"
  899. else begin
  900. let len = String.length s in
  901. let half = len lsr 1 in
  902. (split (String.sub s 0 half) plus ) ^ (split (String.sub s half (len-half)) "+" )
  903. end
  904. in
  905. let escaped = Ast.s_escape ~hex:false s in
  906. let hexed = (special_to_hex escaped) in
  907. if (String.length hexed <= 16000 ) then
  908. "HX_HCSTRING(\"" ^ hexed ^ "\"," ^ (gen_string_hash s) ^ ")"
  909. else
  910. "(" ^ (split s "" ) ^ ")"
  911. ;;
  912. let const_char_star s =
  913. let escaped = Ast.s_escape ~hex:false s in
  914. "\"" ^ special_to_hex escaped ^ "\"";
  915. ;;
  916. (* When we are in a "real" object, we refer to ourselves as "this", but
  917. if we are in a local class that is used to generate return values,
  918. we use the fake "__this" pointer.
  919. If we are in an "Anon" object, then the "this" refers to the anon object (eg List iterator) *)
  920. let clear_real_this_ptr ctx dynamic_this =
  921. let old_flag = ctx.ctx_real_this_ptr in
  922. let old_dynamic = ctx.ctx_dynamic_this_ptr in
  923. let old_void = ctx.ctx_real_void in
  924. ctx.ctx_real_this_ptr <- false;
  925. ctx.ctx_dynamic_this_ptr <- dynamic_this;
  926. fun () -> (
  927. ctx.ctx_real_this_ptr <- old_flag;
  928. ctx.ctx_dynamic_this_ptr <- old_dynamic;
  929. ctx.ctx_real_void <- old_void;
  930. )
  931. ;;
  932. (* Generate temp variable names *)
  933. let next_anon_function_name ctx =
  934. ctx.ctx_static_id_curr <- ctx.ctx_static_id_curr + 1;
  935. "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_curr);;
  936. let use_anon_function_name ctx =
  937. ctx.ctx_static_id_used <- ctx.ctx_static_id_used + 1;
  938. "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_used);;
  939. let push_anon_names ctx =
  940. let old_used = ctx.ctx_static_id_used in
  941. let old_curr = ctx.ctx_static_id_curr in
  942. let old_depth = ctx.ctx_static_id_depth in
  943. ctx.ctx_static_id_used <- 0;
  944. ctx.ctx_static_id_curr <- 0;
  945. ctx.ctx_static_id_depth <- ctx.ctx_static_id_depth + 1;
  946. ( function () -> (
  947. ctx.ctx_static_id_used <- old_used;
  948. ctx.ctx_static_id_curr <- old_curr;
  949. ctx.ctx_static_id_depth <- old_depth; ) )
  950. ;;
  951. let get_switch_var ctx =
  952. ctx.ctx_switch_id <- ctx.ctx_switch_id + 1;
  953. "_switch_" ^ (string_of_int ctx.ctx_switch_id)
  954. (* If you put on the "-debug" flag, you get extra comments in the source code *)
  955. let debug_expression expression type_too =
  956. "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string expression.etype) else "") ^ " */";;
  957. (* This is like the Type.iter, but also keeps the "retval" flag up to date *)
  958. let rec iter_retval f retval e =
  959. match e.eexpr with
  960. | TConst _
  961. | TLocal _
  962. | TBreak
  963. | TContinue
  964. | TTypeExpr _ ->
  965. ()
  966. | TArray (e1,e2)
  967. | TBinop (_,e1,e2) ->
  968. f true e1;
  969. f true e2;
  970. | TWhile (e1,e2,_) ->
  971. f true e1;
  972. f false e2;
  973. | TFor (_,e1,e2) ->
  974. f true e1;
  975. f false e2;
  976. | TThrow e
  977. | TField (e,_)
  978. | TEnumParameter (e,_,_)
  979. | TUnop (_,_,e) ->
  980. f true e
  981. | TParenthesis e | TMeta(_,e) ->
  982. f retval e
  983. | TBlock expr_list when retval ->
  984. let rec return_last = function
  985. | [] -> ()
  986. | expr :: [] -> f true expr
  987. | expr :: exprs -> f false expr; return_last exprs in
  988. return_last expr_list
  989. | TArrayDecl el
  990. | TNew (_,_,el) ->
  991. List.iter (f true ) el
  992. | TBlock el ->
  993. List.iter (f false ) el
  994. | TObjectDecl fl ->
  995. List.iter (fun (_,e) -> f true e) fl
  996. | TCall (e,el) ->
  997. f true e;
  998. List.iter (f true) el
  999. | TVar (_,eo) ->
  1000. (match eo with None -> () | Some e -> f true e)
  1001. | TFunction fu ->
  1002. f false fu.tf_expr
  1003. | TIf (e,e1,e2) ->
  1004. f true e;
  1005. f retval e1;
  1006. (match e2 with None -> () | Some e -> f retval e)
  1007. | TSwitch (e,cases,def) ->
  1008. f true e;
  1009. List.iter (fun (el,e2) -> List.iter (f true) el; f retval e2) cases;
  1010. (match def with None -> () | Some e -> f retval e)
  1011. (* | TMatch (e,_,cases,def) ->
  1012. f true e;
  1013. List.iter (fun (_,_,e) -> f false e) cases;
  1014. (match def with None -> () | Some e -> f false e) *)
  1015. | TTry (e,catches) ->
  1016. f retval e;
  1017. List.iter (fun (_,e) -> f false e) catches
  1018. | TReturn eo ->
  1019. (match eo with None -> () | Some e -> f true e)
  1020. | TCast (e,None) ->
  1021. f retval e
  1022. | TCast (e,_) ->
  1023. f true e
  1024. ;;
  1025. (* Convert an array to a comma separated list of values *)
  1026. let array_arg_list inList =
  1027. let i = ref (0-1) in
  1028. String.concat "," (List.map (fun _ -> incr i; "inArgs[" ^ (string_of_int !i) ^ "]" ) inList)
  1029. let list_num l = string_of_int (List.length l);;
  1030. let only_int_cases cases =
  1031. match cases with
  1032. | [] -> false
  1033. | _ ->
  1034. not (List.exists (fun (cases,expression) ->
  1035. List.exists (fun case -> match case.eexpr with TConst (TInt _) -> false | _ -> true ) cases
  1036. ) cases );;
  1037. (* See if there is a haxe break statement that will be swollowed by c++ break *)
  1038. exception BreakFound;;
  1039. let contains_break expression =
  1040. try (
  1041. let rec check_all expression =
  1042. Type.iter (fun expr -> match expr.eexpr with
  1043. | TBreak -> raise BreakFound
  1044. | TFor _
  1045. | TFunction _
  1046. | TWhile (_,_,_) -> ()
  1047. | _ -> check_all expr;
  1048. ) expression in
  1049. check_all expression;
  1050. false;
  1051. ) with BreakFound -> true;;
  1052. (* Decide is we should look the field up by name *)
  1053. let dynamic_internal = function | "__Is" -> true | _ -> false
  1054. let rec is_null expr =
  1055. match expr.eexpr with
  1056. | TConst TNull -> true
  1057. | TParenthesis expr | TMeta (_,expr) -> is_null expr
  1058. | TCast (e,None) -> is_null e
  1059. | _ -> false
  1060. ;;
  1061. let find_undeclared_variables_ctx ctx undeclared declarations this_suffix allow_this expression =
  1062. let output = ctx.ctx_output in
  1063. let rec find_undeclared_variables undeclared declarations this_suffix allow_this expression =
  1064. match expression.eexpr with
  1065. | TVar (tvar,optional_init) ->
  1066. Hashtbl.add declarations (keyword_remap tvar.v_name) ();
  1067. if (ctx.ctx_debug_level>1) then
  1068. output ("/* found var " ^ tvar.v_name ^ "*/ ");
  1069. (match optional_init with
  1070. | Some expression -> find_undeclared_variables undeclared declarations this_suffix allow_this expression
  1071. | _ -> ())
  1072. | TFunction func -> List.iter ( fun (tvar, opt_val) ->
  1073. if (ctx.ctx_debug_level>1) then
  1074. output ("/* found arg " ^ tvar.v_name ^ " = " ^ (type_string tvar.v_type) ^ " */ ");
  1075. Hashtbl.add declarations (keyword_remap tvar.v_name) () ) func.tf_args;
  1076. find_undeclared_variables undeclared declarations this_suffix false func.tf_expr
  1077. | TTry (try_block,catches) ->
  1078. find_undeclared_variables undeclared declarations this_suffix allow_this try_block;
  1079. List.iter (fun (tvar,catch_expt) ->
  1080. let old_decs = Hashtbl.copy declarations in
  1081. Hashtbl.add declarations (keyword_remap tvar.v_name) ();
  1082. find_undeclared_variables undeclared declarations this_suffix allow_this catch_expt;
  1083. Hashtbl.clear declarations;
  1084. Hashtbl.iter ( Hashtbl.add declarations ) old_decs
  1085. ) catches;
  1086. | TLocal tvar ->
  1087. let name = keyword_remap tvar.v_name in
  1088. if not (Hashtbl.mem declarations name) then
  1089. Hashtbl.replace undeclared name (type_string expression.etype)
  1090. (* | TMatch (condition, enum, cases, default) ->
  1091. find_undeclared_variables undeclared declarations this_suffix allow_this condition;
  1092. List.iter (fun (case_ids,params,expression) ->
  1093. let old_decs = Hashtbl.copy declarations in
  1094. (match params with
  1095. | None -> ()
  1096. | Some l -> List.iter (fun (opt_var) ->
  1097. match opt_var with | Some v -> Hashtbl.add declarations (keyword_remap v.v_name) () | _ -> () )
  1098. l );
  1099. find_undeclared_variables undeclared declarations this_suffix allow_this expression;
  1100. Hashtbl.clear declarations;
  1101. Hashtbl.iter ( Hashtbl.add declarations ) old_decs
  1102. ) cases;
  1103. (match default with | None -> ()
  1104. | Some expr ->
  1105. find_undeclared_variables undeclared declarations this_suffix allow_this expr;
  1106. ); *)
  1107. | TFor (tvar, init, loop) ->
  1108. let old_decs = Hashtbl.copy declarations in
  1109. Hashtbl.add declarations (keyword_remap tvar.v_name) ();
  1110. find_undeclared_variables undeclared declarations this_suffix allow_this init;
  1111. find_undeclared_variables undeclared declarations this_suffix allow_this loop;
  1112. Hashtbl.clear declarations;
  1113. Hashtbl.iter ( Hashtbl.add declarations ) old_decs
  1114. | TConst TSuper
  1115. | TConst TThis ->
  1116. if ((not (Hashtbl.mem declarations "this")) && allow_this) then
  1117. Hashtbl.replace undeclared "this" (type_string_suff this_suffix expression.etype true)
  1118. | TBlock expr_list ->
  1119. let old_decs = Hashtbl.copy declarations in
  1120. List.iter (find_undeclared_variables undeclared declarations this_suffix allow_this ) expr_list;
  1121. (* what is the best way for this ? *)
  1122. Hashtbl.clear declarations;
  1123. Hashtbl.iter ( Hashtbl.add declarations ) old_decs
  1124. | _ -> Type.iter (find_undeclared_variables undeclared declarations this_suffix allow_this) expression
  1125. in
  1126. find_undeclared_variables undeclared declarations this_suffix allow_this expression
  1127. ;;
  1128. let rec is_dynamic_in_cpp ctx expr =
  1129. let expr_type = type_string ( match follow expr.etype with TFun (args,ret) -> ret | _ -> expr.etype) in
  1130. ctx.ctx_dbgout ( "/* idic: " ^ expr_type ^ " */" );
  1131. if ( expr_type="Dynamic" || expr_type="cpp::ArrayBase") then
  1132. true
  1133. else begin
  1134. let result = (
  1135. match expr.eexpr with
  1136. | TEnumParameter( obj, _, index ) ->
  1137. true (* TODO? *)
  1138. | TField( obj, field ) ->
  1139. let name = field_name field in
  1140. ctx.ctx_dbgout ("/* ?tfield "^name^" */");
  1141. if (is_dynamic_member_lookup_in_cpp ctx obj field) then
  1142. (
  1143. ctx.ctx_dbgout "/* tf=dynobj */";
  1144. true
  1145. )
  1146. else if (is_dynamic_member_return_in_cpp ctx obj field) then
  1147. (
  1148. ctx.ctx_dbgout "/* tf=dynret */";
  1149. true
  1150. )
  1151. else
  1152. (
  1153. ctx.ctx_dbgout "/* tf=notdyn */";
  1154. false
  1155. )
  1156. | TConst TThis when ((not ctx.ctx_real_this_ptr) && ctx.ctx_dynamic_this_ptr) ->
  1157. ctx.ctx_dbgout ("/* dthis */"); true
  1158. | TArray (obj,index) -> let dyn = is_dynamic_in_cpp ctx obj in
  1159. ctx.ctx_dbgout ("/* aidr:" ^ (if dyn then "Dyn" else "Not") ^ " */");
  1160. dyn;
  1161. | TTypeExpr _ -> false
  1162. | TCall(func,args) ->
  1163. (match follow func.etype with
  1164. | TFun (args,ret) -> ctx.ctx_dbgout ("/* ret = "^ (type_string ret) ^" */");
  1165. is_dynamic_in_cpp ctx func
  1166. | _ -> ctx.ctx_dbgout "/* not TFun */"; true
  1167. );
  1168. | TParenthesis(expr) | TMeta(_,expr) -> is_dynamic_in_cpp ctx expr
  1169. | TCast (e,None) -> (type_string expr.etype) = "Dynamic"
  1170. | TLocal { v_name = "__global__" } -> false
  1171. | TConst TNull -> true
  1172. | _ -> ctx.ctx_dbgout "/* other */"; false (* others ? *) )
  1173. in
  1174. ctx.ctx_dbgout (if result then "/* Y */" else "/* N */" );
  1175. result
  1176. end
  1177. and is_dynamic_member_lookup_in_cpp ctx field_object field =
  1178. let member = field_name field in
  1179. ctx.ctx_dbgout ("/*mem."^member^".*/");
  1180. if (is_internal_member member) then false else
  1181. if (is_pointer field_object.etype true) then false else
  1182. if (match field_object.eexpr with | TTypeExpr _ -> ctx.ctx_dbgout "/*!TTypeExpr*/"; true | _ -> false) then false else
  1183. if (is_dynamic_in_cpp ctx field_object) then true else
  1184. if (is_array field_object.etype) then false else (
  1185. let tstr = type_string field_object.etype in
  1186. ctx.ctx_dbgout ("/* ts:"^tstr^"*/");
  1187. match tstr with
  1188. (* Internal classes have no dynamic members *)
  1189. | "::String" | "Null" | "::hx::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> ctx.ctx_dbgout ("/* ok:" ^ (type_string field_object.etype) ^ " */"); false
  1190. | "Dynamic" -> true
  1191. | name ->
  1192. let full_name = name ^ "." ^ member in
  1193. ctx.ctx_dbgout ("/* t:" ^ full_name ^ " */");
  1194. try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in
  1195. ctx.ctx_dbgout ("/* =" ^ mem_type ^ "*/");
  1196. false )
  1197. with Not_found -> not (is_extern_class_instance field_object)
  1198. )
  1199. and is_dynamic_member_return_in_cpp ctx field_object field =
  1200. let member = field_name field in
  1201. if (is_array field_object.etype) then false else
  1202. if (is_pointer field_object.etype true) then false else
  1203. if (is_internal_member member) then false else
  1204. match field_object.eexpr with
  1205. | TTypeExpr t ->
  1206. let full_name = "::" ^ (join_class_path (t_path t) "::" ) ^ "." ^ member in
  1207. ctx.ctx_dbgout ("/*static:"^ full_name^"*/");
  1208. ( try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic"||mem_type="cpp::ArrayBase" )
  1209. with Not_found -> true )
  1210. | _ ->
  1211. let tstr = type_string field_object.etype in
  1212. (match tstr with
  1213. (* Internal classes have no dynamic members *)
  1214. | "::String" | "Null" | "::hx::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> false
  1215. | "Dynamic" | "cpp::ArrayBase" -> ctx.ctx_dbgout "/*D*/"; true
  1216. | name ->
  1217. let full_name = name ^ "." ^ member in
  1218. ctx.ctx_dbgout ("/*R:"^full_name^"*/");
  1219. try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic"||mem_type="cpp::ArrayBase" )
  1220. with Not_found -> true )
  1221. ;;
  1222. let cast_if_required ctx expr to_type =
  1223. let expr_type = (type_string expr.etype) in
  1224. ctx.ctx_dbgout ( "/* cir: " ^ expr_type ^ " */" );
  1225. if (is_dynamic_in_cpp ctx expr) then
  1226. ctx.ctx_output (".Cast< " ^ to_type ^ " >()" )
  1227. ;;
  1228. let is_matching_interface_type t0 t1 =
  1229. (match (follow t0),(follow t1) with
  1230. | TInst (k0,_), TInst(k1,_) -> k0==k1
  1231. | _ -> false
  1232. )
  1233. ;;
  1234. let default_value_string = function
  1235. | TInt i -> Printf.sprintf "%ld" i
  1236. | TFloat float_as_string -> "((Float)" ^ float_as_string ^ ")"
  1237. | TString s -> str s
  1238. | TBool b -> (if b then "true" else "false")
  1239. | TNull -> "null()"
  1240. | _ -> "/* Hmmm */"
  1241. ;;
  1242. let generate_default_values ctx args prefix =
  1243. List.iter ( fun (v,o) -> let type_str = type_string v.v_type in
  1244. let name = (keyword_remap v.v_name) in
  1245. match o with
  1246. | Some TNull -> ()
  1247. | Some const ->
  1248. ctx.ctx_output (type_str ^ " " ^ name ^ " = " ^ prefix ^ name ^ ".Default(" ^
  1249. (default_value_string const) ^ ");\n")
  1250. | _ -> () ) args;;
  1251. let return_type_string t =
  1252. match t with
  1253. | TFun (_,ret) -> type_string ret
  1254. | _ -> ""
  1255. ;;
  1256. let get_return_type field =
  1257. match follow field.cf_type with
  1258. | TFun (_,return_type) -> return_type
  1259. | _ -> raise Not_found
  1260. ;;
  1261. let has_default_values args =
  1262. List.exists ( fun (_,o) -> match o with
  1263. | Some TNull -> false
  1264. | Some _ -> true
  1265. | _ -> false ) args ;;
  1266. exception PathFound of string;;
  1267. let strip_file ctx file = (match Common.defined ctx Common.Define.AbsolutePath with
  1268. | true -> file
  1269. | false -> let flen = String.length file in
  1270. (* Not quite right - should probably test is file exists *)
  1271. try
  1272. List.iter (fun path ->
  1273. let plen = String.length path in
  1274. if (flen>plen && path=(String.sub file 0 plen ))
  1275. then raise (PathFound (String.sub file plen (flen-plen)) ) )
  1276. (ctx.class_path @ ctx.std_path);
  1277. file;
  1278. with PathFound tail ->
  1279. tail)
  1280. ;;
  1281. let hx_stack_push ctx output clazz func_name pos =
  1282. if ctx.ctx_debug_level > 0 then begin
  1283. let stripped_file = strip_file ctx.ctx_common pos.pfile in
  1284. let esc_file = (Ast.s_escape stripped_file) in
  1285. ctx.ctx_file_info := PMap.add stripped_file pos.pfile !(ctx.ctx_file_info);
  1286. if (ctx.ctx_debug_level>0) then begin
  1287. let full_name = clazz ^ "." ^ func_name ^ (
  1288. if (clazz="*") then
  1289. (" (" ^ esc_file ^ ":" ^ (string_of_int (Lexer.get_error_line pos) ) ^ ")")
  1290. else "") in
  1291. let hash_class_func = gen_hash 0 (clazz^"."^func_name) in
  1292. let hash_file = gen_hash 0 stripped_file in
  1293. output ("HX_STACK_FRAME(\"" ^ clazz ^ "\",\"" ^ func_name ^ "\"," ^ hash_class_func ^ ",\"" ^
  1294. full_name ^ "\",\"" ^ esc_file ^ "\"," ^
  1295. (string_of_int (Lexer.get_error_line pos) ) ^ "," ^ hash_file ^ ")\n")
  1296. end
  1297. end
  1298. ;;
  1299. (*
  1300. This is the big one.
  1301. Once you get inside a function, all code is generated (recursively) as a "expression".
  1302. "retval" is tracked to determine whether the value on an expression is actually used.
  1303. eg, if the result of a block (ie, the last expression in the list) is used, then
  1304. we have to do some funky stuff to generate a local function.
  1305. Some things that change less often are stored in the context and are extracted
  1306. at the top for simplicity.
  1307. *)
  1308. let gen_expression_tree ctx retval expression_tree set_var tail_code =
  1309. let writer = ctx.ctx_writer in
  1310. let output_i = writer#write_i in
  1311. let output = ctx.ctx_output in
  1312. let rec define_local_function_ctx func_name func_def =
  1313. let remap_this = function | "this" -> "__this" | other -> other in
  1314. let rec define_local_function func_name func_def =
  1315. let declarations = Hashtbl.create 0 in
  1316. let undeclared = Hashtbl.create 0 in
  1317. (* '__global__', '__cpp__' are always defined *)
  1318. Hashtbl.add declarations "__global__" ();
  1319. Hashtbl.add declarations "__cpp__" ();
  1320. Hashtbl.add declarations "__trace" ();
  1321. (* Add args as defined variables *)
  1322. List.iter ( fun (arg_var, opt_val) ->
  1323. if (ctx.ctx_debug_level>1) then
  1324. output ("/* found arg " ^ arg_var.v_name ^ " = " ^ (type_string arg_var.v_type) ^" */ ");
  1325. Hashtbl.add declarations (keyword_remap arg_var.v_name) () ) func_def.tf_args;
  1326. find_undeclared_variables_ctx ctx undeclared declarations "" true func_def.tf_expr;
  1327. let has_this = Hashtbl.mem undeclared "this" in
  1328. if (has_this) then Hashtbl.remove undeclared "this";
  1329. let typed_vars = hash_iterate undeclared (fun key value -> value ^ "," ^ (keyword_remap key) ) in
  1330. let func_name_sep = func_name ^ (if List.length typed_vars > 0 then "," else "") in
  1331. output_i ("HX_BEGIN_LOCAL_FUNC_S" ^ (list_num typed_vars) ^ "(" ^
  1332. (if has_this then "hx::LocalThisFunc," else "hx::LocalFunc,") ^ func_name_sep ^
  1333. (String.concat "," typed_vars) ^ ")\n" );
  1334. output_i ("int __ArgCount() const { return " ^ (string_of_int (List.length func_def.tf_args)) ^"; }\n");
  1335. (* actual function, called "run" *)
  1336. let args_and_types = List.map
  1337. (fun (v,_) -> (type_string v.v_type) ^ " " ^ (keyword_remap v.v_name) ) func_def.tf_args in
  1338. let block = is_block func_def.tf_expr in
  1339. let func_type = type_string func_def.tf_type in
  1340. output_i (func_type ^ " run(" ^ (gen_arg_list func_def.tf_args "__o_") ^ ")");
  1341. let close_defaults =
  1342. if (has_default_values func_def.tf_args) then begin
  1343. writer#begin_block;
  1344. output_i "";
  1345. generate_default_values ctx func_def.tf_args "__o_";
  1346. output_i "";
  1347. true;
  1348. end
  1349. else
  1350. false in
  1351. let pop_real_this_ptr = clear_real_this_ptr ctx true in
  1352. writer#begin_block;
  1353. if (ctx.ctx_debug_level>0) then begin
  1354. hx_stack_push ctx output_i "*" func_name func_def.tf_expr.epos;
  1355. if (has_this && ctx.ctx_debug_level>0) then
  1356. output_i ("HX_STACK_THIS(__this.mPtr)\n");
  1357. List.iter (fun (v,_) -> output_i ("HX_STACK_ARG(" ^ (keyword_remap v.v_name) ^ ",\"" ^ v.v_name ^"\")\n") )
  1358. func_def.tf_args;
  1359. end;
  1360. if (block) then begin
  1361. output_i "";
  1362. gen_expression false func_def.tf_expr;
  1363. output_i "return null();\n";
  1364. end else begin
  1365. (* Save old values, and equalize for new input ... *)
  1366. let pop_names = push_anon_names ctx in
  1367. find_local_functions_and_return_blocks_ctx false func_def.tf_expr;
  1368. (match func_def.tf_expr.eexpr with
  1369. | TReturn (Some return_expression) when (func_type<>"Void") ->
  1370. output_i "return ";
  1371. gen_expression true return_expression;
  1372. | TReturn (Some return_expression) ->
  1373. output_i "";
  1374. gen_expression false return_expression;
  1375. | _ ->
  1376. output_i "";
  1377. gen_block_expression func_def.tf_expr;
  1378. );
  1379. output ";\n";
  1380. output_i "return null();\n";
  1381. pop_names();
  1382. end;
  1383. writer#end_block;
  1384. if close_defaults then writer#end_block;
  1385. pop_real_this_ptr();
  1386. let return = if (type_string func_def.tf_type ) = "Void" then "(void)" else "return" in
  1387. output_i ("HX_END_LOCAL_FUNC" ^ (list_num args_and_types) ^ "(" ^ return ^ ")\n\n");
  1388. Hashtbl.replace ctx.ctx_local_function_args func_name
  1389. (if (ctx.ctx_real_this_ptr) then
  1390. String.concat "," (hash_keys undeclared)
  1391. else
  1392. String.concat "," (List.map remap_this (hash_keys undeclared)) )
  1393. in
  1394. define_local_function func_name func_def
  1395. and find_local_functions_and_return_blocks_ctx retval expression =
  1396. let rec find_local_functions_and_return_blocks retval expression =
  1397. match expression.eexpr with
  1398. | TBlock _ ->
  1399. if (retval) then begin
  1400. define_local_return_block_ctx expression (next_anon_function_name ctx) true;
  1401. end (* else we are done *)
  1402. | TTry (_, _)
  1403. | TSwitch (_, _, _) when retval ->
  1404. define_local_return_block_ctx expression (next_anon_function_name ctx) true;
  1405. | TObjectDecl ( ("fileName" , { eexpr = (TConst (TString file)) }) ::
  1406. ("lineNumber" , { eexpr = (TConst (TInt line)) }) ::
  1407. ("className" , { eexpr = (TConst (TString class_name)) }) ::
  1408. ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> ()
  1409. | TObjectDecl decl_list ->
  1410. let name = next_anon_function_name ctx in
  1411. define_local_return_block_ctx expression name true;
  1412. | TFunction func ->
  1413. let func_name = next_anon_function_name ctx in
  1414. output "\n";
  1415. define_local_function_ctx func_name func
  1416. | TField (obj,_) | TEnumParameter (obj,_,_) when (is_null obj) -> ( )
  1417. | TArray (obj,_) when (is_null obj) -> ( )
  1418. | TIf ( _ , _ , _ ) when retval -> (* ? operator style *)
  1419. iter_retval find_local_functions_and_return_blocks retval expression
  1420. | TSwitch (_, _, _) when retval -> ( )
  1421. (* | TMatch ( cond , _, _, _) *)
  1422. | TWhile ( cond , _, _ )
  1423. | TIf ( cond , _, _ )
  1424. | TSwitch ( cond , _, _) -> iter_retval find_local_functions_and_return_blocks true cond
  1425. | _ -> iter_retval find_local_functions_and_return_blocks retval expression
  1426. in find_local_functions_and_return_blocks retval expression
  1427. and define_local_return_block_ctx expression name retval =
  1428. let check_this = function | "this" when not ctx.ctx_real_this_ptr -> "__this" | x -> x in
  1429. let rec define_local_return_block expression =
  1430. let declarations = Hashtbl.create 0 in
  1431. let undeclared = Hashtbl.create 0 in
  1432. (* '__global__' is always defined *)
  1433. Hashtbl.add declarations "__global__" ();
  1434. Hashtbl.add declarations "__cpp__" ();
  1435. Hashtbl.add declarations "__trace" ();
  1436. find_undeclared_variables_ctx ctx undeclared declarations "_obj" true expression;
  1437. let vars = (hash_keys undeclared) in
  1438. let args = String.concat "," (List.map check_this (hash_keys undeclared)) in
  1439. Hashtbl.replace ctx.ctx_local_return_block_args name args;
  1440. output_i ("struct " ^ name);
  1441. writer#begin_block;
  1442. let ret_type = if (not retval) then "Void" else
  1443. match expression.eexpr with
  1444. | TObjectDecl _ -> "Dynamic"
  1445. | _ -> type_string expression.etype in
  1446. (* TODO - analyse usage *)
  1447. let pass_by_value name = (String.length name >=5 ) && (String.sub name 0 5 = "_this") in
  1448. output_i ("inline static " ^ ret_type ^ " Block( ");
  1449. output (String.concat "," (
  1450. (List.map
  1451. (fun var ->
  1452. let var_type = Hashtbl.find undeclared var in
  1453. (* Args passed into inline-block should be references, so they can be changed.
  1454. Fake 'this' pointers can't be changed, so needn't be references *)
  1455. match var with
  1456. | "this" -> "hx::ObjectPtr< " ^ var_type ^ " > __this"
  1457. | name when (pass_by_value name) -> var_type ^ " " ^ name
  1458. | name -> var_type ^ " &" ^name
  1459. ) vars) ) );
  1460. output (")");
  1461. let return_data = ret_type <> "Void" in
  1462. writer#begin_block;
  1463. hx_stack_push ctx output_i "*" "closure" expression.epos;
  1464. output_i "";
  1465. let pop_real_this_ptr = clear_real_this_ptr ctx false in
  1466. (match expression.eexpr with
  1467. | TObjectDecl decl_list ->
  1468. writer#begin_block;
  1469. output_i "hx::Anon __result = hx::Anon_obj::Create();\n";
  1470. let pop_names = push_anon_names ctx in
  1471. List.iter (function (name,value) ->
  1472. find_local_functions_and_return_blocks_ctx true value;
  1473. output_i ( "__result->Add(" ^ (str name) ^ " , ");
  1474. gen_expression true value;
  1475. output (if is_function_expr value then ",true" else ",false" );
  1476. output (");\n");
  1477. ) decl_list;
  1478. pop_names();
  1479. output_i "return __result;\n";
  1480. writer#end_block;
  1481. | TBlock _ ->
  1482. ctx.ctx_return_from_block <- return_data;
  1483. ctx.ctx_return_from_internal_node <- false;
  1484. gen_expression false expression;
  1485. | TCall(func,args) ->
  1486. writer#begin_block;
  1487. let pop_names = push_anon_names ctx in
  1488. find_local_functions_and_return_blocks_ctx true func;
  1489. List.iter (find_local_functions_and_return_blocks_ctx true) args;
  1490. ctx.ctx_tcall_expand_args <- true;
  1491. gen_expression return_data expression;
  1492. output ";\n";
  1493. pop_names();
  1494. writer#end_block;
  1495. | _ ->
  1496. ctx.ctx_return_from_block <- false;
  1497. ctx.ctx_return_from_internal_node <- return_data;
  1498. gen_block_expression expression;
  1499. );
  1500. output_i "return null();\n";
  1501. writer#end_block;
  1502. pop_real_this_ptr();
  1503. writer#end_block_line;
  1504. output ";\n";
  1505. in
  1506. define_local_return_block expression
  1507. and gen_expression retval expression =
  1508. let calling = ctx.ctx_calling in
  1509. ctx.ctx_calling <- false;
  1510. let assigning = ctx.ctx_assigning in
  1511. ctx.ctx_assigning <- false;
  1512. let return_from_block = ctx.ctx_return_from_block in
  1513. ctx.ctx_return_from_block <- false;
  1514. let tcall_expand_args = ctx.ctx_tcall_expand_args in
  1515. ctx.ctx_tcall_expand_args <- false;
  1516. let return_from_internal_node = ctx.ctx_return_from_internal_node in
  1517. ctx.ctx_return_from_internal_node <- false;
  1518. let dump_src_pos = ctx.ctx_dump_src_pos in
  1519. ctx.ctx_dump_src_pos <- (fun() -> ());
  1520. (* Annotate source code with debug - can get a bit verbose. Mainly for debugging code gen,
  1521. rather than the run time *)
  1522. if (ctx.ctx_debug_level>1) then begin
  1523. (*if calling then output "/* Call */";*)
  1524. (*if ctx.ctx_real_this_ptr then output "/* this */" else output "/* FAKE __this */";*)
  1525. output (debug_expression expression (ctx.ctx_debug_level>1) );
  1526. end;
  1527. (* Write comma separated list of variables - useful for function args. *)
  1528. let rec gen_expression_list expressions =
  1529. (match expressions with
  1530. | [] -> ()
  1531. | [single] -> gen_expression true single
  1532. | first :: remaining ->
  1533. gen_expression true first;
  1534. output ",";
  1535. gen_expression_list remaining
  1536. ) in
  1537. (* this will add a cast if boxing / unboxing an objective-c type *)
  1538. let check_objc_unbox expression to_type =
  1539. if is_objc_type to_type && not (is_objc_type expression.etype) then
  1540. { expression with eexpr = TCast(expression,None); etype = to_type }
  1541. else
  1542. expression
  1543. in
  1544. let check_objc_box expression to_type =
  1545. if is_objc_type expression.etype && not (is_objc_type to_type) then
  1546. { expression with eexpr = TCast(expression,None); etype = to_type }
  1547. else
  1548. expression
  1549. in
  1550. let add_objc_cast_if_needed expression =
  1551. (* objc-specific: since all `id` derived types are boxed to the same type,
  1552. we need to take one extra care when unboxing, and cast them to their
  1553. actual type *)
  1554. let is_cast =
  1555. retval && is_objc_type expression.etype && is_dynamic_in_cpp ctx expression
  1556. in
  1557. if is_cast then begin
  1558. output ("( (" ^ (type_string expression.etype) ^ ") (id) (");
  1559. ") )";
  1560. end else
  1561. ""
  1562. in
  1563. let rec gen_bin_op_string expr1 op expr2 =
  1564. let cast = (match op with
  1565. | ">>" | "<<" | "&" | "|" | "^" -> "int("
  1566. | "&&" | "||" -> "bool("
  1567. | "/" -> "Float("
  1568. | _ -> "") in
  1569. if (op <> "=") then output "(";
  1570. if ( cast <> "") then output cast;
  1571. gen_expression true expr1;
  1572. if ( cast <> "") then output ")";
  1573. output (" " ^ op ^ " ");
  1574. if ( cast <> "") then output cast;
  1575. gen_expression true expr2;
  1576. if ( cast <> "") then output ")";
  1577. if (op <> "=") then output ")";
  1578. in
  1579. let rec is_const_string_term expr =
  1580. match expr.eexpr with
  1581. | TConst( TString _ ) -> true
  1582. | TBinop (OpAdd,e1,e2) -> (is_const_string_term e1) && (is_const_string_term e2 )
  1583. | _ -> false
  1584. in
  1585. let rec combine_string_terms expr =
  1586. match expr.eexpr with
  1587. | TConst( TString s ) -> s
  1588. | TBinop (OpAdd,e1,e2) -> (combine_string_terms e1) ^ (combine_string_terms e2 )
  1589. | _ -> ""
  1590. in
  1591. let rec gen_bin_op op expr1 expr2 =
  1592. let expr1, expr2 = match op with
  1593. | Ast.OpAssign | Ast.OpAssignOp _ -> expr1, check_objc_unbox expr2 expr1.etype
  1594. | Ast.OpEq | Ast.OpNotEq -> check_objc_box expr1 expr2.etype, check_objc_box expr2 expr1.etype
  1595. | _ -> expr1,expr2
  1596. in
  1597. match op with
  1598. | Ast.OpAdd when (is_const_string_term expr1) && (is_const_string_term expr2) ->
  1599. output (str ((combine_string_terms expr1) ^ (combine_string_terms expr2)) )
  1600. | Ast.OpAssign -> ctx.ctx_assigning <- true;
  1601. gen_bin_op_string expr1 "=" expr2
  1602. | Ast.OpUShr ->
  1603. output "hx::UShr(";
  1604. gen_expression true expr1;
  1605. output ",";
  1606. gen_expression true expr2;
  1607. output ")";
  1608. | Ast.OpMod ->
  1609. output "hx::Mod(";
  1610. gen_expression true expr1;
  1611. output ",";
  1612. gen_expression true expr2;
  1613. output ")";
  1614. | Ast.OpAssignOp bin_op ->
  1615. output (match bin_op with
  1616. | Ast.OpAdd -> "hx::AddEq("
  1617. | Ast.OpMult -> "hx::MultEq("
  1618. | Ast.OpDiv -> "hx::DivEq("
  1619. | Ast.OpSub -> "hx::SubEq("
  1620. | Ast.OpAnd -> "hx::AndEq("
  1621. | Ast.OpOr -> "hx::OrEq("
  1622. | Ast.OpXor -> "hx::XorEq("
  1623. | Ast.OpShl -> "hx::ShlEq("
  1624. | Ast.OpShr -> "hx::ShrEq("
  1625. | Ast.OpUShr -> "hx::UShrEq("
  1626. | Ast.OpMod -> "hx::ModEq("
  1627. | _ -> error "Unknown OpAssignOp" expression.epos );
  1628. ctx.ctx_assigning <- true;
  1629. gen_expression true expr1;
  1630. output ",";
  1631. gen_expression true expr2;
  1632. output ")"
  1633. | Ast.OpNotEq -> gen_bin_op_string expr1 "!=" expr2
  1634. | Ast.OpEq -> gen_bin_op_string expr1 "==" expr2
  1635. | _ -> gen_bin_op_string expr1 (Ast.s_binop op) expr2
  1636. in
  1637. let gen_array_cast cast_name real_type call =
  1638. output (cast_name ^ "< " ^ real_type ^ " >" ^ call)
  1639. in
  1640. let rec check_array_element_cast array_type cast_name call =
  1641. match follow array_type with
  1642. | TInst (klass,[element]) ->
  1643. ( match type_string element with
  1644. | _ when is_struct_access element -> ()
  1645. | x when cant_be_null element -> ()
  1646. | _ when is_interface_type element -> ()
  1647. | "::String" | "Dynamic" -> ()
  1648. | real_type -> gen_array_cast cast_name real_type call
  1649. )
  1650. | TAbstract (abs,pl) when abs.a_impl <> None ->
  1651. check_array_element_cast (Abstract.get_underlying_type abs pl) cast_name call
  1652. | _ -> ()
  1653. in
  1654. let rec check_array_cast array_type =
  1655. match follow array_type with
  1656. | x when is_interface_type x -> ()
  1657. | TInst (klass,[element]) ->
  1658. let name = type_string element in
  1659. if ( is_object name && not (is_interface_type element) ) then
  1660. gen_array_cast ".StaticCast" "Array<Dynamic>" "()"
  1661. else
  1662. gen_array_cast ".StaticCast" (type_string array_type) "()"
  1663. | TAbstract (abs,pl) when abs.a_impl <> None ->
  1664. check_array_cast (Abstract.get_underlying_type abs pl)
  1665. | _ -> ()
  1666. in
  1667. let rec gen_tfield field_object field =
  1668. let member = (field_name field) in
  1669. let remap_name = keyword_remap member in
  1670. let already_dynamic = ref false in
  1671. (match field_object.eexpr with
  1672. (* static access ... *)
  1673. | TTypeExpr type_def ->
  1674. (match get_field_access_meta field Meta.Native with
  1675. | "" ->
  1676. let class_name = "::" ^ (join_class_path_remap (t_path type_def) "::" ) in
  1677. if (class_name="::String") then
  1678. output ("::String::" ^ remap_name)
  1679. else
  1680. output (class_name ^ "_obj::" ^ remap_name);
  1681. | native -> output native
  1682. )
  1683. (* Special internal access *)
  1684. | TLocal { v_name = "__global__" } ->
  1685. output ("::" ^ member )
  1686. | TConst TSuper -> output (if ctx.ctx_real_this_ptr then "this" else "__this");
  1687. output ("->super::" ^ remap_name)
  1688. | TConst TThis when ctx.ctx_real_this_ptr -> output ( "this->" ^ remap_name )
  1689. | TConst TNull -> output "null()"
  1690. | _ ->
  1691. gen_expression true field_object;
  1692. ctx.ctx_dbgout "/* TField */";
  1693. (* toString is the only internal member that can be set... *)
  1694. let settingInternal = assigning && member="toString" in
  1695. let isString = (type_string field_object.etype)="::String" in
  1696. if (is_struct_access field_object.etype) then
  1697. output ( "." ^ member )
  1698. else if (is_internal_member member && not settingInternal) then begin
  1699. output ( (if isString then "." else "->") ^ member );
  1700. end else if (settingInternal || is_dynamic_member_lookup_in_cpp ctx field_object field) then begin
  1701. if assigning then
  1702. output ( "->__FieldRef(" ^ (str member) ^ ")" )
  1703. else
  1704. output ( "->__Field(" ^ (str member) ^ ", hx::paccDynamic )" );
  1705. already_dynamic := true;
  1706. end else begin
  1707. if (isString) then
  1708. output ( "." ^ remap_name )
  1709. else begin
  1710. cast_if_required ctx field_object (type_string field_object.etype);
  1711. let remap_name = if (type_string field_object.etype)="cpp::ArrayBase" then
  1712. match remap_name with
  1713. | "length" -> remap_name
  1714. | _ -> "__" ^ remap_name
  1715. else
  1716. remap_name
  1717. in
  1718. output ( "->" ^ remap_name );
  1719. if (calling && (is_array field_object.etype) && remap_name="iterator" ) then
  1720. check_array_element_cast field_object.etype "Fast" "";
  1721. already_dynamic := (match field with
  1722. | FInstance(_,_,var) when is_var_field var -> true
  1723. | _ -> false);
  1724. end;
  1725. end;
  1726. );
  1727. if ( (not !already_dynamic) && (not calling) && (not assigning) && (is_function_member expression) ) then
  1728. output "_dyn()";
  1729. in
  1730. let gen_local_block_call () =
  1731. let func_name = use_anon_function_name ctx in (
  1732. try
  1733. output ( func_name ^ "::Block(" ^
  1734. (Hashtbl.find ctx.ctx_local_return_block_args func_name) ^ ")" )
  1735. with Not_found ->
  1736. (*error ("Block function " ^ func_name ^ " not found" ) expression.epos;*)
  1737. output ("/* Block function " ^ func_name ^ " not found */" );
  1738. )
  1739. in
  1740. match expression.eexpr with
  1741. | TConst TNull when not retval ->
  1742. output "Dynamic()";
  1743. | TCall (func, arg_list) when (match func.eexpr with
  1744. | TLocal { v_name = "__cpp__" } -> true
  1745. | _ -> false) ->
  1746. ( match arg_list with
  1747. | [{ eexpr = TConst (TString code) }] -> output (format_code code);
  1748. | ({ eexpr = TConst (TString code) } as ecode) :: tl ->
  1749. Codegen.interpolate_code ctx.ctx_common (format_code code) tl output (gen_expression true) ecode.epos
  1750. | _ -> error "__cpp__'s first argument must be a string" func.epos;
  1751. )
  1752. | TCall (func, arg_list) when tcall_expand_args->
  1753. let arg_string = ref "" in
  1754. let idx = ref 0 in
  1755. List.iter (fun arg ->
  1756. let a_name = "__a" ^ string_of_int(!idx) in
  1757. arg_string := !arg_string ^ (if !arg_string<>"" then "," else "") ^ a_name;
  1758. idx := !idx + 1;
  1759. output_i ( (type_string arg.etype) ^ " " ^ a_name ^ " = ");
  1760. gen_expression true arg;
  1761. output ";\n";
  1762. ) arg_list;
  1763. output_i (if retval then "return " else "");
  1764. ctx.ctx_calling <- true;
  1765. gen_expression true func;
  1766. output ("(" ^ !arg_string ^ ");\n");
  1767. | TCall (func, arg_list) when is_fromStaticFunction_call func ->
  1768. (match arg_list with
  1769. | [ {eexpr = TField( _, FStatic(klass,field)) } ] ->
  1770. let signature = cpp_function_signature field.cf_type "" in
  1771. let name = keyword_remap field.cf_name in
  1772. let void_cast = has_meta_key field.cf_meta Meta.Void in
  1773. output ("::cpp::Function< " ^ signature ^">(");
  1774. if (void_cast) then output "hx::AnyCast(";
  1775. output ("&::" ^(join_class_path klass.cl_path "::")^ "_obj::" ^ name );
  1776. if (void_cast) then output ")";
  1777. output (" )");
  1778. | _ -> error "fromStaticFunction must take a static function" expression.epos;
  1779. )
  1780. | TCall ({ eexpr = TField(fexpr,field) }, arg_list) when is_objc_call field ->
  1781. output "[ ";
  1782. (match field with
  1783. | FStatic(cl,_) ->
  1784. output (join_class_path_remap cl.cl_path "::")
  1785. | FInstance _ ->
  1786. gen_expression true fexpr
  1787. | _ -> assert false);
  1788. let names = ExtString.String.nsplit (field_name field) ":" in
  1789. let field_name, arg_names = match names with
  1790. | name :: args -> name, args
  1791. | _ -> assert false (* per nsplit specs, this should never happen *)
  1792. in
  1793. output (" " ^ field_name);
  1794. (try match arg_list, arg_names with
  1795. | [], _ -> ()
  1796. | [single_arg], _ -> output ": "; gen_expression true single_arg
  1797. | first_arg :: args, arg_names ->
  1798. output ": ";
  1799. gen_expression true first_arg;
  1800. ctx.ctx_calling <- true;
  1801. List.iter2 (fun arg arg_name ->
  1802. output (" " ^ arg_name ^ ": ");
  1803. gen_expression true arg) args arg_names
  1804. with | Invalid_argument _ -> (* not all arguments names are known *)
  1805. error (
  1806. "The function called here with name " ^ (String.concat ":" names) ^
  1807. " does not contain the right amount of arguments' names as required" ^
  1808. " by the objective-c calling / naming convention:" ^
  1809. " expected " ^ (string_of_int (List.length arg_list)) ^
  1810. " and found " ^ (string_of_int (List.length arg_names)))
  1811. expression.epos);
  1812. output " ]"
  1813. | TCall (func, [arg]) when is_addressOf_call func && not (is_lvalue arg) ->
  1814. error "addressOf must take a local or member variable" expression.epos;
  1815. | TCall (func, arg_list) ->
  1816. let after_cast = add_objc_cast_if_needed expression in
  1817. let rec is_variable e = match e.eexpr with
  1818. | TField _ | TEnumParameter _ -> false
  1819. | TLocal { v_name = "__global__" } -> false
  1820. | TParenthesis p | TMeta(_,p) -> is_variable p
  1821. | _ -> true
  1822. in
  1823. let expr_type = type_string expression.etype in
  1824. let rec is_fixed_override e = (not (is_scalar expr_type)) && match e.eexpr with
  1825. | TField(obj,FInstance(_,_,field) ) ->
  1826. let cpp_type = member_type ctx obj field.cf_name in
  1827. (not (is_scalar cpp_type)) && (
  1828. let fixed = (cpp_type<>"?") && (expr_type<>"Dynamic") && (cpp_type<>"Dynamic") &&
  1829. (cpp_type<>expr_type) && (expr_type<>"Void") && (cpp_type<>"cpp::ArrayBase") in
  1830. if (fixed && (ctx.ctx_debug_level>1) ) then begin
  1831. output ("/* " ^ (cpp_type) ^ " != " ^ expr_type ^ " -> cast */");
  1832. end;
  1833. fixed
  1834. )
  1835. | TParenthesis p | TMeta(_,p) -> is_fixed_override p
  1836. | _ -> false
  1837. in
  1838. let check_extern_pointer_cast e = match (remove_parens e).eexpr with
  1839. | TField (_,FInstance(class_def,_,_) )
  1840. | TField (_,FStatic(class_def,_) )
  1841. when class_def.cl_extern ->
  1842. (try
  1843. let return_type = expression.etype in
  1844. (is_pointer return_type false) &&
  1845. ( output ( (type_string return_type) ^ "(" ); true; )
  1846. with Not_found -> false )
  1847. | _ -> false
  1848. in
  1849. let is_super = (match func.eexpr with | TConst TSuper -> true | _ -> false ) in
  1850. if (ctx.ctx_debug_level>1) then output ("/* TCALL ret=" ^ expr_type ^ "*/");
  1851. let cast_result = (not is_super) && (is_fixed_override func) in
  1852. if (cast_result) then output ("hx::TCast< " ^ expr_type ^ " >::cast(");
  1853. let cast_result = cast_result || check_extern_pointer_cast func in
  1854. (* If a static function has @:native('new abc')
  1855. c++ new has lower precedence than in haxe so ( ) must be used *)
  1856. let paren_result =
  1857. if is_native_with_space func then
  1858. ( output "("; true )
  1859. else
  1860. false
  1861. in
  1862. ctx.ctx_calling <- true;
  1863. gen_expression true func;
  1864. output "(";
  1865. gen_expression_list arg_list;
  1866. output ")";
  1867. if paren_result then
  1868. output ")";
  1869. if (cast_result) then output (")");
  1870. if ( (is_variable func) && (not (is_cpp_function_member func) ) &&
  1871. (expr_type<>"Dynamic" && expr_type<>"cpp::ArrayBase" ) && (not is_super) ) then
  1872. ctx.ctx_output (".Cast< " ^ expr_type ^ " >()" );
  1873. let rec cast_array_output func =
  1874. match func.eexpr with
  1875. | TField(obj,field) when is_array obj.etype ->
  1876. (match field_name field with
  1877. | "pop" | "shift" | "__unsafe_get" | "__unsafe_set" -> check_array_element_cast obj.etype ".StaticCast" "()"
  1878. | "map" -> check_array_cast expression.etype
  1879. | _ -> ()
  1880. )
  1881. | TParenthesis p | TMeta(_,p) -> cast_array_output p
  1882. | _ -> ()
  1883. in
  1884. cast_array_output func;
  1885. output after_cast
  1886. | TBlock expr_list ->
  1887. if (retval) then
  1888. gen_local_block_call()
  1889. else begin
  1890. writer#begin_block;
  1891. dump_src_pos();
  1892. (* Save old values, and equalize for new input ... *)
  1893. let pop_names = push_anon_names ctx in
  1894. let remaining = ref (List.length expr_list) in
  1895. List.iter (fun expression ->
  1896. let want_value = (return_from_block && !remaining = 1) in
  1897. find_local_functions_and_return_blocks_ctx want_value expression;
  1898. if (ctx.ctx_debug_level>0) then
  1899. output_i ("HX_STACK_LINE(" ^ (string_of_int (Lexer.get_error_line expression.epos)) ^ ")\n" );
  1900. output_i "";
  1901. ctx.ctx_return_from_internal_node <- return_from_internal_node;
  1902. if (want_value) then output "return ";
  1903. gen_expression want_value expression;
  1904. decr remaining;
  1905. writer#terminate_line
  1906. ) expr_list;
  1907. writer#end_block;
  1908. pop_names()
  1909. end
  1910. | TTypeExpr type_expr ->
  1911. let klass = "::" ^ (join_class_path_remap (t_path type_expr) "::" ) in
  1912. let klass1 = if klass="::Array" then "Array<int>" else klass in
  1913. output ("hx::ClassOf< " ^ klass1 ^ " >()")
  1914. | TReturn _ when retval ->
  1915. unsupported expression.epos
  1916. | TReturn optional_expr ->
  1917. output "";
  1918. ( match optional_expr with
  1919. | Some return_expression when ( (type_string expression.etype)="Void") ->
  1920. output "return null(";
  1921. gen_expression true return_expression;
  1922. output ")";
  1923. | Some return_expression ->
  1924. output "return ";
  1925. gen_expression true return_expression
  1926. | _ -> output (if ctx.ctx_real_void then "return" else "return null()")
  1927. )
  1928. | TConst const ->
  1929. (match const with
  1930. | TInt i when ctx.ctx_for_extern -> output (Printf.sprintf "%ld" i)
  1931. | TInt i -> output (Printf.sprintf "(int)%ld" i)
  1932. | TFloat float_as_string -> output ("((Float)" ^ float_as_string ^")")
  1933. | TString s when ctx.ctx_for_extern -> output ("\"" ^ (escape_extern s) ^ "\"")
  1934. | TString s -> output (str s)
  1935. | TBool b -> output (if b then "true" else "false")
  1936. (*| TNull -> output ("((" ^ (type_string expression.etype) ^ ")null())")*)
  1937. | TNull when is_objc_type expression.etype -> output "nil"
  1938. | TNull -> output (if ctx.ctx_for_extern then "null" else "null()")
  1939. | TThis -> output (if ctx.ctx_real_this_ptr then "hx::ObjectPtr<OBJ_>(this)" else "__this")
  1940. | TSuper when calling ->
  1941. output (if ctx.ctx_real_this_ptr then
  1942. "super::__construct"
  1943. else
  1944. ("__this->" ^ ctx.ctx_class_super_name ^ "::__construct") )
  1945. | TSuper -> output ("hx::ObjectPtr<super>(" ^ (if ctx.ctx_real_this_ptr then "this" else "__this.mPtr") ^ ")")
  1946. )
  1947. | TLocal v -> output (keyword_remap v.v_name);
  1948. | TArray (array_expr,_) when (is_null array_expr) -> output "Dynamic()"
  1949. | TArray (array_expr,index) ->
  1950. let dynamic = is_dynamic_in_cpp ctx array_expr || (type_string array_expr.etype) = "cpp::ArrayBase" in
  1951. if ( assigning && (not dynamic) ) then begin
  1952. if (is_array_implementer array_expr.etype) then begin
  1953. output "hx::__ArrayImplRef(";
  1954. gen_expression true array_expr;
  1955. output ",";
  1956. gen_expression true index;
  1957. output ")";
  1958. end else begin
  1959. gen_expression true array_expr;
  1960. output "[";
  1961. gen_expression true index;
  1962. output "]";
  1963. end
  1964. end else if (assigning) then begin
  1965. (* output (" /*" ^ (type_string array_expr.etype) ^ " */ "); *)
  1966. output "hx::IndexRef((";
  1967. gen_expression true array_expr;
  1968. output ").mPtr,";
  1969. gen_expression true index;
  1970. output ")";
  1971. end else if ( dynamic ) then begin
  1972. gen_expression true array_expr;
  1973. output "->__GetItem(";
  1974. gen_expression true index;
  1975. output ")";
  1976. end else begin
  1977. gen_expression true array_expr;
  1978. output "->__get(";
  1979. gen_expression true index;
  1980. output ")";
  1981. if not (is_pointer array_expr.etype true) then
  1982. check_array_element_cast array_expr.etype ".StaticCast" "()";
  1983. end
  1984. (* Get precidence matching haxe ? *)
  1985. | TBinop (op,expr1,expr2) -> gen_bin_op op expr1 expr2
  1986. | TField (expr,_) | TEnumParameter (expr,_,_) when (is_null expr) ->
  1987. output "hx::Throw(HX_CSTRING(\"Invalid field access on null object\"))"
  1988. | TEnumParameter (expr,ef,i) ->
  1989. let enum = match follow ef.ef_type with
  1990. | TEnum(en,_) | TFun(_,TEnum(en,_)) -> en
  1991. | _ -> assert false
  1992. in
  1993. output ( "(::" ^ (join_class_path_remap enum.e_path "::") ^ "(");
  1994. gen_expression true expr;
  1995. output ( "))->__Param(" ^ (string_of_int i) ^ ")")
  1996. | TField (field_object,field) ->
  1997. let after_cast = add_objc_cast_if_needed expression in
  1998. gen_tfield field_object field;
  1999. output after_cast
  2000. | TParenthesis expr when not retval ->
  2001. gen_expression retval expr;
  2002. | TParenthesis expr -> output "("; gen_expression retval expr; output ")"
  2003. | TMeta (_,expr) -> gen_expression retval expr;
  2004. | TObjectDecl (
  2005. ("fileName" , { eexpr = (TConst (TString file)) }) ::
  2006. ("lineNumber" , { eexpr = (TConst (TInt line)) }) ::
  2007. ("className" , { eexpr = (TConst (TString class_name)) }) ::
  2008. ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) ->
  2009. output ("hx::SourceInfo(" ^ (str file) ^ "," ^ (Printf.sprintf "%ld" line) ^ "," ^
  2010. (str class_name) ^ "," ^ (str meth) ^ ")" )
  2011. | TObjectDecl decl_list -> gen_local_block_call()
  2012. | TArrayDecl decl_list ->
  2013. (* gen_type output expression.etype; *)
  2014. let tstr = (type_string_suff "_obj" expression.etype true) in
  2015. if tstr="Dynamic" then
  2016. output "Dynamic( Array_obj<Dynamic>::__new()"
  2017. else
  2018. output ( (type_string_suff "_obj" expression.etype true) ^ "::__new()");
  2019. List.iter ( fun elem -> output ".Add(";
  2020. gen_expression true elem;
  2021. output ")" ) decl_list;
  2022. if tstr="Dynamic" then output ")";
  2023. | TNew (klass,params,expressions) ->
  2024. let is_param_array = match klass.cl_path with
  2025. | ([],"Array") when is_dynamic_array_param (List.hd params) -> true | _ -> false
  2026. in
  2027. if is_param_array then
  2028. output "Dynamic( Array_obj<Dynamic>::__new() )"
  2029. else begin
  2030. if (klass.cl_path = ([],"String")) then
  2031. output "::String("
  2032. else
  2033. output ( ( class_string klass "_obj" params true) ^ "::__new(" );
  2034. gen_expression_list expressions;
  2035. output ")"
  2036. end
  2037. | TUnop (Ast.NegBits,Ast.Prefix,expr) ->
  2038. output "~(int)(";
  2039. gen_expression true expr;
  2040. output ")"
  2041. | TUnop (op,Ast.Prefix,expr) ->
  2042. ctx.ctx_assigning <- (match op with Ast.Increment | Ast.Decrement -> true | _ ->false);
  2043. output (Ast.s_unop op);
  2044. output "(";
  2045. gen_expression true expr;
  2046. output ")"
  2047. | TUnop (op,Ast.Postfix,expr) ->
  2048. ctx.ctx_assigning <- true;
  2049. output "(";
  2050. gen_expression true expr;
  2051. output ")";
  2052. output (Ast.s_unop op)
  2053. | TFunction func ->
  2054. let func_name = use_anon_function_name ctx in
  2055. (
  2056. try
  2057. output ( " Dynamic(new " ^ func_name ^ "(" ^
  2058. (Hashtbl.find ctx.ctx_local_function_args func_name) ^ "))" )
  2059. with Not_found ->
  2060. (*error ("function " ^ func_name ^ " not found.") expression.epos; *)
  2061. output ("function " ^ func_name ^ " not found.");
  2062. )
  2063. | TVar (tvar,optional_init) ->
  2064. let count = ref 1 in (* TODO: this section can be simplified *)
  2065. if (retval && !count==1) then
  2066. (match optional_init with
  2067. | None -> output "null()"
  2068. | Some expression -> gen_expression true expression )
  2069. else begin
  2070. let type_name = (type_string tvar.v_type) in
  2071. output (if type_name="Void" then "Dynamic" else type_name );
  2072. let name = (keyword_remap tvar.v_name) in
  2073. output (" " ^ name );
  2074. (match optional_init with
  2075. | None -> ()
  2076. | Some expression -> output " = "; gen_expression true expression);
  2077. count := !count -1;
  2078. if (ctx.ctx_debug_level>0) then
  2079. output (";\t\tHX_STACK_VAR(" ^name ^",\""^ tvar.v_name ^"\")");
  2080. if (!count > 0) then begin output ";\n"; output_i "" end
  2081. end
  2082. | TFor (tvar, init, loop) ->
  2083. output ("for(::cpp::FastIterator_obj< " ^ (type_string tvar.v_type) ^
  2084. " > *__it = ::cpp::CreateFastIterator< "^(type_string tvar.v_type) ^ " >(");
  2085. gen_expression true init;
  2086. output ("); __it->hasNext(); )");
  2087. ctx.ctx_writer#begin_block;
  2088. output_i ( (type_string tvar.v_type) ^ " " ^ (keyword_remap tvar.v_name) ^ " = __it->next();\n" );
  2089. output_i "";
  2090. gen_expression false loop;
  2091. output ";\n";
  2092. ctx.ctx_writer#end_block;
  2093. | TIf (condition, if_expr, optional_else_expr) ->
  2094. (match optional_else_expr with
  2095. | Some else_expr ->
  2096. if (retval) then begin
  2097. output "( (";
  2098. gen_expression true condition;
  2099. output ") ? ";
  2100. let type_str = match (type_string expression.etype) with
  2101. | "Void" -> "Dynamic"
  2102. | other -> other
  2103. in
  2104. output (type_str ^ "(");
  2105. gen_expression true if_expr;
  2106. output ") : ";
  2107. output (type_str ^ "(");
  2108. gen_expression true else_expr;
  2109. output ") )";
  2110. end else begin
  2111. output "if (";
  2112. gen_expression true condition;
  2113. output ")";
  2114. gen_block_expression if_expr;
  2115. output_i "else";
  2116. gen_block_expression else_expr;
  2117. end
  2118. | _ -> output "if (";
  2119. gen_expression true condition;
  2120. output ")";
  2121. gen_block_expression if_expr;
  2122. )
  2123. | TWhile (condition, repeat, Ast.NormalWhile ) ->
  2124. output "while(";
  2125. gen_expression true condition;
  2126. output ")";
  2127. gen_block_expression repeat
  2128. | TWhile (condition, repeat, Ast.DoWhile ) ->
  2129. output "do";
  2130. gen_block_expression repeat;
  2131. output "while(";
  2132. gen_expression true condition;
  2133. output ")"
  2134. (* These have already been defined in find_local_return_blocks ... *)
  2135. | TTry (_,_)
  2136. | TSwitch (_,_,_) when (retval && (not return_from_internal_node) ) ->
  2137. gen_local_block_call()
  2138. | TSwitch (condition,cases,optional_default) ->
  2139. let switch_on_int_constants = (only_int_cases cases) && (not (contains_break expression)) in
  2140. if (switch_on_int_constants) then begin
  2141. output "switch( (int)";
  2142. gen_expression true condition;
  2143. output ")";
  2144. ctx.ctx_writer#begin_block;
  2145. List.iter (fun (cases_list,expression) ->
  2146. output_i "";
  2147. List.iter (fun value -> output "case ";
  2148. gen_expression true value;
  2149. output ": " ) cases_list;
  2150. ctx.ctx_return_from_block <- return_from_internal_node;
  2151. gen_block_expression expression;
  2152. output_i ";break;\n";
  2153. ) cases;
  2154. (match optional_default with | None -> ()
  2155. | Some default ->
  2156. output_i "default: ";
  2157. ctx.ctx_return_from_block <- return_from_internal_node;
  2158. gen_block_expression default;
  2159. );
  2160. ctx.ctx_writer#end_block;
  2161. end else begin
  2162. let tmp_name = get_switch_var ctx in
  2163. output ( (type_string condition.etype) ^ " " ^ tmp_name ^ " = " );
  2164. gen_expression true condition;
  2165. output ";\n";
  2166. let else_str = ref "" in
  2167. if (List.length cases > 0) then
  2168. List.iter (fun (cases,expression) ->
  2169. output_i ( !else_str ^ "if ( ");
  2170. else_str := "else ";
  2171. let or_str = ref "" in
  2172. List.iter (fun value ->
  2173. output (!or_str ^ " ( " ^ tmp_name ^ "==");
  2174. gen_expression true value;
  2175. output ")";
  2176. or_str := " || ";
  2177. ) cases;
  2178. output (")");
  2179. ctx.ctx_return_from_block <- return_from_internal_node;
  2180. gen_block_expression expression;
  2181. ) cases;
  2182. (match optional_default with | None -> ()
  2183. | Some default ->
  2184. output_i ( !else_str ^ " ");
  2185. ctx.ctx_return_from_block <- return_from_internal_node;
  2186. gen_block_expression default;
  2187. output ";\n";
  2188. );
  2189. end
  2190. | TTry (expression, catch_list) ->
  2191. output "try\n";
  2192. output_i "{\n";
  2193. let counter = ref 0 in
  2194. List.iter (fun (v, e) ->
  2195. let type_name = type_string v.v_type in
  2196. output_i ("HX_STACK_CATCHABLE(" ^ type_name ^ ", " ^ string_of_int !counter ^ ");\n");
  2197. counter := !counter + 1;)
  2198. catch_list;
  2199. output_i("");
  2200. (* Move this "inside" the try call ... *)
  2201. ctx.ctx_return_from_block <-return_from_internal_node;
  2202. gen_block_expression expression;
  2203. output_i "}\n";
  2204. if (List.length catch_list > 0 ) then begin
  2205. output_i "catch(Dynamic __e)";
  2206. ctx.ctx_writer#begin_block;
  2207. let seen_dynamic = ref false in
  2208. let else_str = ref "" in
  2209. List.iter (fun (v,expression) ->
  2210. let type_name = type_string v.v_type in
  2211. if (type_name="Dynamic") then begin
  2212. seen_dynamic := true;
  2213. output_i !else_str;
  2214. end else
  2215. output_i (!else_str ^ "if (__e.IsClass< " ^ type_name ^ " >() )");
  2216. ctx.ctx_writer#begin_block;
  2217. output_i "HX_STACK_BEGIN_CATCH\n";
  2218. output_i (type_name ^ " " ^ v.v_name ^ " = __e;");
  2219. (* Move this "inside" the catch call too ... *)
  2220. ctx.ctx_return_from_block <-return_from_internal_node;
  2221. gen_block_expression (mk_block expression);
  2222. ctx.ctx_writer#end_block;
  2223. else_str := "else ";
  2224. ) catch_list;
  2225. if (not !seen_dynamic) then begin
  2226. output_i "else {\n";
  2227. output_i " HX_STACK_DO_THROW(__e);\n";
  2228. output_i "}\n";
  2229. end;
  2230. ctx.ctx_writer#end_block;
  2231. end;
  2232. | TBreak -> output "break"
  2233. | TContinue -> output "continue"
  2234. | TThrow expression ->
  2235. output "HX_STACK_DO_THROW(";
  2236. gen_expression true expression;
  2237. output ")";
  2238. | TCast (cast,None) when is_objc_type expression.etype && not (is_objc_type cast.etype) ->
  2239. let ret_type = type_string expression.etype in
  2240. output ("( (" ^ ret_type ^ ") (id) (");
  2241. gen_expression true cast;
  2242. output ") )"
  2243. | TCast (cast,None) when (not retval) || (type_string expression.etype) = "Void" ->
  2244. gen_expression retval cast;
  2245. | TCast (cast,None) ->
  2246. let ret_type = type_string expression.etype in
  2247. let from_type = if is_dynamic_in_cpp ctx cast then "Dynamic" else type_string cast.etype in
  2248. if (from_type = ret_type) then begin
  2249. gen_expression true cast
  2250. end else begin
  2251. output ("((" ^ ret_type ^ ")(");
  2252. gen_expression true cast;
  2253. output "))";
  2254. end;
  2255. | TCast (e1,Some t) ->
  2256. let class_name = (join_class_path_remap (t_path t) "::" ) in
  2257. if (class_name="Array") then
  2258. output ("hx::TCastToArray(" )
  2259. else
  2260. output ("hx::TCast< ::" ^ class_name ^ " >::cast(" );
  2261. gen_expression true e1;
  2262. output ")";
  2263. and gen_block_expression expression =
  2264. gen_expression false (mk_block expression)
  2265. in
  2266. if (set_var<>"") then begin
  2267. find_local_functions_and_return_blocks_ctx true expression_tree;
  2268. output set_var;
  2269. end;
  2270. gen_expression retval expression_tree;
  2271. output tail_code
  2272. ;;
  2273. (*
  2274. let is_dynamic_haxe_method f =
  2275. match follow f.cf_type with
  2276. | TFun _ when f.cf_expr = None -> true
  2277. | _ ->
  2278. (match f.cf_expr with
  2279. | Some { eexpr = TFunction fd } when f.cf_set = MethodAccess true -> true
  2280. | Some { eexpr = TFunction fd } when f.cf_set = NormalAccess -> true
  2281. | _ -> false);;
  2282. *)
  2283. let is_dynamic_haxe_method f =
  2284. (match f.cf_expr, f.cf_kind with
  2285. | Some { eexpr = TFunction _ }, (Var _ | Method MethDynamic) -> true
  2286. | _ -> false);;
  2287. let is_data_member field =
  2288. match field.cf_expr with
  2289. | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field
  2290. | _ -> true;;
  2291. let is_override class_def field =
  2292. List.exists (fun f -> f.cf_name = field) class_def.cl_overrides
  2293. ;;
  2294. let rec all_virtual_functions clazz =
  2295. (List.fold_left (fun result elem -> match follow elem.cf_type, elem.cf_kind with
  2296. | _, Method MethDynamic -> result
  2297. | TFun (args,return_type), Method _ when not (is_override clazz elem.cf_name ) -> (elem,args,return_type) :: result
  2298. | _,_ -> result ) [] clazz.cl_ordered_fields)
  2299. @ (match clazz.cl_super with
  2300. | Some def -> all_virtual_functions (fst def)
  2301. | _ -> [] )
  2302. ;;
  2303. let reflective class_def field = not (
  2304. (Meta.has Meta.NativeGen class_def.cl_meta) ||
  2305. (Meta.has Meta.Unreflective class_def.cl_meta) ||
  2306. (Meta.has Meta.Unreflective field.cf_meta) ||
  2307. (match field.cf_type with
  2308. | TInst (klass,_) -> Meta.has Meta.Unreflective klass.cl_meta
  2309. | _ -> false
  2310. )
  2311. )
  2312. ;;
  2313. let field_arg_count field =
  2314. match follow field.cf_type, field.cf_kind with
  2315. | _, Method MethDynamic -> -1
  2316. | TFun (args,return_type), Method _ -> List.length args
  2317. | _,_ -> -1
  2318. ;;
  2319. (* external mem Dynamic & *)
  2320. let gen_field ctx class_def class_name ptr_name dot_name is_static is_interface field =
  2321. let output = ctx.ctx_output in
  2322. ctx.ctx_real_this_ptr <- not is_static;
  2323. let remap_name = keyword_remap field.cf_name in
  2324. let decl = get_meta_string field.cf_meta Meta.Decl in
  2325. let has_decl = decl <> "" in
  2326. let nativeGen = has_meta_key class_def.cl_meta Meta.NativeGen in
  2327. if (is_interface) then begin
  2328. (* Just the dynamic glue - not even that ... *)
  2329. ()
  2330. end else (match field.cf_expr with
  2331. (* Function field *)
  2332. | Some { eexpr = TFunction function_def } ->
  2333. let return_type = (type_string function_def.tf_type) in
  2334. let nargs = string_of_int (List.length function_def.tf_args) in
  2335. let is_void = (type_string function_def.tf_type ) = "Void" in
  2336. let ret = if is_void then "(void)" else "return " in
  2337. let output_i = ctx.ctx_writer#write_i in
  2338. let orig_debug = ctx.ctx_debug_level in
  2339. let dump_src = if ((Meta.has Meta.NoStack field.cf_meta)||(Meta.has Meta.NoDebug field.cf_meta) || orig_debug<1 || nativeGen) then begin
  2340. ctx.ctx_debug_level <- 0;
  2341. (fun()->())
  2342. end else begin
  2343. (fun() ->
  2344. hx_stack_push ctx output_i dot_name field.cf_name function_def.tf_expr.epos;
  2345. if (not is_static) then output_i ("HX_STACK_THIS(this)\n");
  2346. List.iter (fun (v,_) -> output_i ("HX_STACK_ARG(" ^ (keyword_remap v.v_name) ^ ",\"" ^ v.v_name ^"\")\n") )
  2347. function_def.tf_args )
  2348. end in
  2349. if (not (is_dynamic_haxe_method field)) then begin
  2350. (* The actual function definition *)
  2351. let real_void = is_void && (has_meta_key field.cf_meta Meta.Void) in
  2352. let fake_void = is_void && not real_void in
  2353. output (if real_void then "void" else return_type );
  2354. output (" " ^ class_name ^ "::" ^ remap_name ^ "(" );
  2355. output (gen_arg_list function_def.tf_args "__o_");
  2356. output ")\n";
  2357. ctx.ctx_real_this_ptr <- true;
  2358. ctx.ctx_real_void <- real_void;
  2359. ctx.ctx_dynamic_this_ptr <- false;
  2360. let code = (get_code field.cf_meta Meta.FunctionCode) in
  2361. let tail_code = (get_code field.cf_meta Meta.FunctionTailCode) in
  2362. if (has_default_values function_def.tf_args) then begin
  2363. ctx.ctx_writer#begin_block;
  2364. generate_default_values ctx function_def.tf_args "__o_";
  2365. dump_src();
  2366. output code;
  2367. gen_expression_tree ctx false function_def.tf_expr "" tail_code;
  2368. if (fake_void) then output "\treturn null();\n";
  2369. ctx.ctx_writer#end_block;
  2370. end else begin
  2371. let add_block = is_void || (code <> "") || (tail_code <> "") in
  2372. if (add_block) then ctx.ctx_writer#begin_block;
  2373. ctx.ctx_dump_src_pos <- dump_src;
  2374. output code;
  2375. gen_expression_tree ctx false (mk_block function_def.tf_expr) "" tail_code;
  2376. if (add_block) then begin
  2377. if (fake_void) then output "\treturn null();\n";
  2378. ctx.ctx_writer#end_block;
  2379. end;
  2380. end;
  2381. output "\n\n";
  2382. let nonVirtual = has_meta_key field.cf_meta Meta.NonVirtual in
  2383. let doDynamic = (nonVirtual || not (is_override class_def field.cf_name ) ) && (reflective class_def field ) in
  2384. (* generate dynamic version too ... *)
  2385. if ( doDynamic ) then begin
  2386. if (is_static) then output "STATIC_";
  2387. output ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^
  2388. remap_name ^ "," ^ ret ^ ")\n\n");
  2389. end;
  2390. end else begin
  2391. ctx.ctx_real_this_ptr <- false;
  2392. ctx.ctx_dynamic_this_ptr <- false;
  2393. let func_name = "__default_" ^ (remap_name) in
  2394. output ("HX_BEGIN_DEFAULT_FUNC(" ^ func_name ^ "," ^ class_name ^ ")\n");
  2395. output return_type;
  2396. output (" run(" ^ (gen_arg_list function_def.tf_args "__o_") ^ ")");
  2397. ctx.ctx_dump_src_pos <- dump_src;
  2398. if (is_void) then begin
  2399. ctx.ctx_writer#begin_block;
  2400. generate_default_values ctx function_def.tf_args "__o_";
  2401. gen_expression_tree ctx false function_def.tf_expr "" "";
  2402. output "return null();\n";
  2403. ctx.ctx_writer#end_block;
  2404. end else if (has_default_values function_def.tf_args) then begin
  2405. ctx.ctx_writer#begin_block;
  2406. generate_default_values ctx function_def.tf_args "__o_";
  2407. gen_expression_tree ctx false function_def.tf_expr "" "";
  2408. ctx.ctx_writer#end_block;
  2409. end else
  2410. gen_expression_tree ctx false (mk_block function_def.tf_expr) "" "";
  2411. output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n");
  2412. output ("HX_END_DEFAULT_FUNC\n\n");
  2413. if (is_static) then
  2414. output ( "Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n");
  2415. end;
  2416. ctx.ctx_debug_level <- orig_debug
  2417. (* Data field *)
  2418. | _ when has_decl ->
  2419. if is_static then begin
  2420. output ( class_name ^ "::" ^ remap_name ^ "_decl ");
  2421. output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n");
  2422. end
  2423. | _ ->
  2424. if is_static && (not (is_extern_field field)) then begin
  2425. gen_type ctx field.cf_type;
  2426. output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n");
  2427. end
  2428. )
  2429. ;;
  2430. let gen_field_init ctx field =
  2431. let output = ctx.ctx_output in
  2432. let remap_name = keyword_remap field.cf_name in
  2433. (match field.cf_expr with
  2434. (* Function field *)
  2435. | Some { eexpr = TFunction function_def } ->
  2436. if (is_dynamic_haxe_method field) then begin
  2437. let func_name = "__default_" ^ (remap_name) in
  2438. output ( "\t" ^ remap_name ^ " = new " ^ func_name ^ ";\n\n" );
  2439. end
  2440. (* Data field *)
  2441. | _ -> (match field.cf_expr with
  2442. | Some expr ->
  2443. let var_name = ( match remap_name with
  2444. | "__meta__" -> "\t__mClass->__meta__="
  2445. | "__rtti" -> "\t__mClass->__rtti__="
  2446. | _ -> "\t" ^ remap_name ^ "= ") in
  2447. gen_expression_tree ctx true expr var_name ";\n";
  2448. | _ -> ( )
  2449. );
  2450. )
  2451. ;;
  2452. let has_field_init field =
  2453. match field.cf_expr with
  2454. (* Function field *)
  2455. | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field
  2456. (* Data field *)
  2457. | Some _ -> true
  2458. | _ -> false
  2459. ;;
  2460. let gen_member_def ctx class_def is_static is_interface field =
  2461. let output = ctx.ctx_output in
  2462. let remap_name = keyword_remap field.cf_name in
  2463. let nativeGen = has_meta_key class_def.cl_meta Meta.NativeGen in
  2464. if (is_interface) then begin
  2465. match follow field.cf_type, field.cf_kind with
  2466. | _, Method MethDynamic -> ()
  2467. | TFun (args,return_type), Method _ ->
  2468. output ( (if (not is_static) then " virtual " else " " ) ^ type_string return_type);
  2469. output (" " ^ remap_name ^ "( " );
  2470. output (gen_tfun_interface_arg_list args);
  2471. output (if (not is_static) then ")=0;\n" else ");\n");
  2472. if (reflective class_def field) then begin
  2473. if (Common.defined ctx.ctx_common Define.DynamicInterfaceClosures) then
  2474. output (" inline Dynamic " ^ remap_name ^ "_dyn() { return __Field( " ^ (str field.cf_name) ^ ", hx::paccDynamic); }\n" )
  2475. else
  2476. output (" virtual Dynamic " ^ remap_name ^ "_dyn()=0;\n" );
  2477. end
  2478. | _ -> ( )
  2479. end else begin
  2480. let decl = get_meta_string field.cf_meta Meta.Decl in
  2481. let has_decl = decl <> "" in
  2482. if (has_decl) then
  2483. output ( " typedef " ^ decl ^ ";\n" );
  2484. output (if is_static then "\t\tstatic " else "\t\t");
  2485. (match field.cf_expr with
  2486. | Some { eexpr = TFunction function_def } ->
  2487. let nonVirtual = has_meta_key field.cf_meta Meta.NonVirtual in
  2488. let doDynamic = (nonVirtual || not (is_override class_def field.cf_name ) ) && (reflective class_def field ) in
  2489. if ( is_dynamic_haxe_method field ) then begin
  2490. if ( doDynamic ) then begin
  2491. output ("Dynamic " ^ remap_name ^ ";\n");
  2492. output (if is_static then "\t\tstatic " else "\t\t");
  2493. output ("inline Dynamic &" ^ remap_name ^ "_dyn() " ^ "{return " ^ remap_name^ "; }\n")
  2494. end
  2495. end else begin
  2496. let return_type = (type_string function_def.tf_type) in
  2497. if ( not is_static && not nonVirtual ) then output "virtual ";
  2498. output (if return_type="Void" && (has_meta_key field.cf_meta Meta.Void) then "void" else return_type );
  2499. output (" " ^ remap_name ^ "(" );
  2500. output (gen_arg_list function_def.tf_args "" );
  2501. output ");\n";
  2502. if ( doDynamic ) then begin
  2503. output (if is_static then "\t\tstatic " else "\t\t");
  2504. output ("Dynamic " ^ remap_name ^ "_dyn();\n" )
  2505. end;
  2506. end;
  2507. output "\n";
  2508. | _ when has_decl ->
  2509. output ( remap_name ^ "_decl " ^ remap_name ^ ";\n" );
  2510. (* Variable access *)
  2511. | _ ->
  2512. (* Variable access *)
  2513. gen_type ctx field.cf_type;
  2514. output (" " ^ remap_name ^ ";\n" );
  2515. (* Add a "dyn" function for variable to unify variable/function access *)
  2516. (match follow field.cf_type with
  2517. | _ when nativeGen -> ()
  2518. | TFun (_,_) ->
  2519. output (if is_static then "\t\tstatic " else "\t\t");
  2520. gen_type ctx field.cf_type;
  2521. output (" &" ^ remap_name ^ "_dyn() { return " ^ remap_name ^ ";}\n" )
  2522. | _ -> (match field.cf_kind with
  2523. | Var { v_read = AccCall } when (not is_static) && (is_dynamic_accessor ("get_" ^ field.cf_name) "get" field class_def) ->
  2524. output ("\t\tDynamic get_" ^ field.cf_name ^ ";\n" )
  2525. | _ -> ()
  2526. );
  2527. (match field.cf_kind with
  2528. | Var { v_write = AccCall } when (not is_static) && (is_dynamic_accessor ("set_" ^ field.cf_name) "set" field class_def) ->
  2529. output ("\t\tDynamic set_" ^ field.cf_name ^ ";\n" )
  2530. | _ -> ()
  2531. )
  2532. )
  2533. );
  2534. end
  2535. ;;
  2536. let path_of_string path =
  2537. ["@verbatim"], path
  2538. ;;
  2539. (*
  2540. Get a list of all classes referred to by the class/enum definition
  2541. These are used for "#include"ing the appropriate header files,
  2542. or for building the dependencies in the Build.xml file
  2543. *)
  2544. let find_referenced_types ctx obj super_deps constructor_deps header_only for_depends include_super_args =
  2545. let types = ref PMap.empty in
  2546. let rec add_type in_path =
  2547. if ( not (PMap.mem in_path !types)) then begin
  2548. types := (PMap.add in_path () !types);
  2549. try
  2550. List.iter add_type (Hashtbl.find super_deps in_path);
  2551. with Not_found -> ()
  2552. end
  2553. in
  2554. let add_extern_class klass =
  2555. let include_file = get_meta_string_path klass.cl_meta (if for_depends then Meta.Depend else Meta.Include) in
  2556. if (include_file<>"") then
  2557. add_type ( path_of_string include_file )
  2558. else if (not for_depends) && (has_meta_key klass.cl_meta Meta.Include) then
  2559. add_type klass.cl_path
  2560. in
  2561. let add_native_gen_class klass =
  2562. let include_file = get_meta_string_path klass.cl_meta (if for_depends then Meta.Depend else Meta.Include) in
  2563. if (include_file<>"") then
  2564. add_type ( path_of_string include_file )
  2565. else if for_depends then
  2566. add_type klass.cl_path
  2567. else
  2568. add_type ( path_of_string ( (join_class_path klass.cl_path "/") ^ ".h") )
  2569. in
  2570. let visited = ref [] in
  2571. let rec visit_type in_type =
  2572. if not (List.exists (fun t2 -> Type.fast_eq in_type t2) !visited) then begin
  2573. visited := in_type :: !visited;
  2574. begin match follow in_type with
  2575. | TMono r -> (match !r with None -> () | Some t -> visit_type t)
  2576. | TEnum (enum,params) -> add_type enum.e_path
  2577. (* If a class has a template parameter, then we treat it as dynamic - except
  2578. for the Array, Class, FastIterator or Pointer classes, for which we do a fully typed object *)
  2579. | TInst (klass,params) ->
  2580. (match klass.cl_path with
  2581. | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator")
  2582. | (["cpp"],"Pointer") | (["cpp"],"ConstPointer") | (["cpp"],"Function")
  2583. | (["cpp"],"RawPointer") | (["cpp"],"RawConstPointer") -> List.iter visit_type params
  2584. | _ when is_native_gen_class klass -> add_native_gen_class klass
  2585. | _ when is_extern_class klass -> add_extern_class klass
  2586. | _ -> (match klass.cl_kind with KTypeParameter _ -> () | _ -> add_type klass.cl_path);
  2587. )
  2588. | TFun (args,haxe_type) -> visit_type haxe_type;
  2589. List.iter (fun (_,_,t) -> visit_type t; ) args;
  2590. | _ -> ()
  2591. end;
  2592. visited := List.tl !visited;
  2593. end
  2594. in
  2595. let rec visit_params expression =
  2596. begin
  2597. let rec visit_expression = fun expression ->
  2598. (* Expand out TTypeExpr (ie, the name of a class, as used for static access etc ... *)
  2599. (match expression.eexpr with
  2600. | TTypeExpr type_def -> ( match type_def with
  2601. | TClassDecl class_def when is_native_gen_class class_def -> add_native_gen_class class_def
  2602. | TClassDecl class_def when is_extern_class class_def -> add_extern_class class_def
  2603. | _ -> add_type (t_path type_def)
  2604. )
  2605. (* Must visit the types, Type.iter will visit the expressions ... *)
  2606. | TTry (e,catches) ->
  2607. List.iter (fun (v,_) -> visit_type v.v_type) catches
  2608. (* Must visit the enum param types, Type.iter will visit the rest ... *)
  2609. (* | TMatch (_,enum,cases,_) ->
  2610. add_type (fst enum).e_path;
  2611. List.iter (fun (case_ids,params,expression) ->
  2612. (match params with
  2613. | None -> ()
  2614. | Some l -> List.iter (function None -> () | Some v -> visit_type v.v_type) l ) ) cases; *)
  2615. (* Must visit type too, Type.iter will visit the expressions ... *)
  2616. | TNew (klass,params,_) -> begin
  2617. visit_type (TInst (klass,params));
  2618. try
  2619. let construct_type = Hashtbl.find constructor_deps klass.cl_path in
  2620. visit_type construct_type.cf_type
  2621. with Not_found -> ();
  2622. end
  2623. (* Must visit type too, Type.iter will visit the expressions ... *)
  2624. | TVar (v,_) ->
  2625. visit_type v.v_type
  2626. (* Must visit enum type too, Type.iter will visit the expressions ... *)
  2627. | TEnumParameter (_,ef,_) -> visit_type (follow ef.ef_type)
  2628. (* Must visit args too, Type.iter will visit the expressions ... *)
  2629. | TFunction func_def ->
  2630. List.iter (fun (v,_) -> visit_type v.v_type) func_def.tf_args;
  2631. | TConst TSuper ->
  2632. (match follow expression.etype with
  2633. | TInst (klass,params) ->
  2634. (try let construct_type = Hashtbl.find constructor_deps klass.cl_path in
  2635. visit_type construct_type.cf_type
  2636. with Not_found -> () )
  2637. | _ -> print_endline ("TSuper : Odd etype ?" ^ ( (type_string expression.etype)) )
  2638. )
  2639. | _ -> ()
  2640. );
  2641. Type.iter visit_expression expression;
  2642. visit_type (follow expression.etype)
  2643. in
  2644. visit_expression expression
  2645. end
  2646. in
  2647. let visit_field field =
  2648. (* Add the type of the expression ... *)
  2649. visit_type field.cf_type;
  2650. if (not header_only) then
  2651. (match field.cf_expr with
  2652. | Some expression -> visit_params expression | _ -> ());
  2653. in
  2654. let visit_class class_def =
  2655. let fields = List.append class_def.cl_ordered_fields class_def.cl_ordered_statics in
  2656. let fields_and_constructor = List.append fields
  2657. (match class_def.cl_constructor with | Some expr -> [expr] | _ -> [] ) in
  2658. List.iter visit_field fields_and_constructor;
  2659. if (include_super_args) then
  2660. List.iter visit_field (List.map (fun (a,_,_) -> a ) (all_virtual_functions class_def ));
  2661. (* Add super & interfaces *)
  2662. if is_native_gen_class class_def then
  2663. add_native_gen_class class_def
  2664. else
  2665. add_type class_def.cl_path;
  2666. in
  2667. let visit_enum enum_def =
  2668. add_type enum_def.e_path;
  2669. PMap.iter (fun _ constructor ->
  2670. (match constructor.ef_type with
  2671. | TFun (args,_) ->
  2672. List.iter (fun (_,_,t) -> visit_type t; ) args;
  2673. | _ -> () );
  2674. ) enum_def.e_constrs;
  2675. if (not header_only) then begin
  2676. let meta = Codegen.build_metadata ctx (TEnumDecl enum_def) in
  2677. match meta with Some expr -> visit_params expr | _ -> ();
  2678. end;
  2679. in
  2680. let inc_cmp i1 i2 =
  2681. String.compare (join_class_path i1 ".") (join_class_path i2 ".")
  2682. in
  2683. (* Body of main function *)
  2684. (match obj with
  2685. | TClassDecl class_def -> visit_class class_def;
  2686. (match class_def.cl_init with Some expression -> visit_params expression | _ -> ())
  2687. | TEnumDecl enum_def -> visit_enum enum_def
  2688. | TTypeDecl _ | TAbstractDecl _ -> (* These are expanded *) ());
  2689. List.sort inc_cmp (List.filter (fun path -> (include_class_header path) ) (pmap_keys !types))
  2690. ;;
  2691. let generate_main_header output_main =
  2692. output_main "#include <hxcpp.h>\n\n";
  2693. output_main "#include <stdio.h>\n\n";
  2694. output_main "extern \"C\" void __hxcpp_main();\n\n";
  2695. output_main "extern \"C\" void __hxcpp_lib_main();\n\n"
  2696. ;;
  2697. let generate_main_footer1 output_main =
  2698. output_main "void __hxcpp_main() {\n";;
  2699. let generate_main_footer2 output_main =
  2700. output_main " }\n\n";
  2701. output_main "void __hxcpp_lib_main() {\n";
  2702. output_main " HX_TOP_OF_STACK\n";
  2703. output_main " hx::Boot();\n";
  2704. output_main " __boot_all();\n";
  2705. output_main " __hxcpp_main();\n";
  2706. output_main " }\n"
  2707. ;;
  2708. let generate_main common_ctx member_types super_deps class_def file_info =
  2709. (* main routine should be a single static function *)
  2710. let main_expression =
  2711. (match class_def.cl_ordered_statics with
  2712. | [{ cf_expr = Some expression }] -> expression;
  2713. | _ -> assert false ) in
  2714. ignore(find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) false false false);
  2715. let depend_referenced = find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) false true false in
  2716. let generate_startup filename is_main =
  2717. (*make_class_directories base_dir ( "src" :: []);*)
  2718. let cpp_file = new_cpp_file common_ctx common_ctx.file ([],filename) in
  2719. let output_main = (cpp_file#write) in
  2720. generate_main_header output_main;
  2721. List.iter ( add_include cpp_file ) depend_referenced;
  2722. output_main "\n\n";
  2723. if is_main then output_main "\n#include <hx/HxcppMain.h>\n\n";
  2724. generate_main_footer1 output_main;
  2725. gen_expression_tree (new_context common_ctx cpp_file 1 file_info) false main_expression "" ";\n";
  2726. generate_main_footer2 output_main;
  2727. cpp_file#close;
  2728. in
  2729. generate_startup "__main__" true;
  2730. generate_startup "__lib__" false
  2731. ;;
  2732. let generate_dummy_main common_ctx =
  2733. let generate_startup filename is_main =
  2734. let main_file = new_cpp_file common_ctx common_ctx.file ([],filename) in
  2735. let output_main = (main_file#write) in
  2736. generate_main_header output_main;
  2737. if is_main then output_main "\n#include <hx/HxcppMain.h>\n\n";
  2738. generate_main_footer1 output_main;
  2739. generate_main_footer2 output_main;
  2740. main_file#close;
  2741. in
  2742. generate_startup "__main__" true;
  2743. generate_startup "__lib__" false
  2744. ;;
  2745. let generate_boot common_ctx boot_enums boot_classes nonboot_classes init_classes =
  2746. (* Write boot class too ... *)
  2747. let base_dir = common_ctx.file in
  2748. let boot_file = new_cpp_file common_ctx base_dir ([],"__boot__") in
  2749. let output_boot = (boot_file#write) in
  2750. output_boot "#include <hxcpp.h>\n\n";
  2751. List.iter ( fun class_path -> boot_file#add_include class_path )
  2752. (boot_enums @ boot_classes @ nonboot_classes);
  2753. output_boot "\nvoid __files__boot();\n";
  2754. output_boot "\nvoid __boot_all()\n{\n";
  2755. output_boot "__files__boot();\n";
  2756. output_boot "hx::RegisterResources( hx::GetResources() );\n";
  2757. List.iter ( fun class_path ->
  2758. output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__register();\n") )
  2759. (boot_enums @ boot_classes @ nonboot_classes);
  2760. let dump_boot =
  2761. List.iter ( fun class_path ->
  2762. output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__boot();\n") ) in
  2763. dump_boot boot_enums;
  2764. List.iter ( fun class_path ->
  2765. output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__init__();\n") ) (List.rev init_classes);
  2766. dump_boot (List.filter (fun path -> is_cpp_class path ) (List.rev boot_classes));
  2767. dump_boot (List.filter (fun path -> not (is_cpp_class path) ) (List.rev boot_classes));
  2768. output_boot "}\n\n";
  2769. boot_file#close;;
  2770. let generate_files common_ctx file_info =
  2771. (* Write __files__ class too ... *)
  2772. let base_dir = common_ctx.file in
  2773. let files_file = new_cpp_file common_ctx base_dir ([],"__files__") in
  2774. let output_files = (files_file#write) in
  2775. let types = common_ctx.types in
  2776. output_files "#include <hxcpp.h>\n\n";
  2777. output_files "namespace hx {\n";
  2778. output_files "const char *__hxcpp_all_files[] = {\n";
  2779. output_files "#ifdef HXCPP_DEBUGGER\n";
  2780. List.iter ( fun file -> output_files ((const_char_star file)^",\n" ) )
  2781. ( List.sort String.compare ( pmap_keys !file_info) );
  2782. output_files "#endif\n";
  2783. output_files " 0 };\n";
  2784. output_files "\n";
  2785. output_files "const char *__hxcpp_all_files_fullpath[] = {\n";
  2786. output_files "#ifdef HXCPP_DEBUGGER\n";
  2787. List.iter ( fun file -> output_files ((const_char_star (
  2788. Common.get_full_path (try Common.find_file common_ctx file with Not_found -> file)
  2789. ))^",\n" ) )
  2790. ( List.sort String.compare ( pmap_keys !file_info) );
  2791. output_files "#endif\n";
  2792. output_files " 0 };\n";
  2793. output_files "\n";
  2794. output_files "const char *__hxcpp_all_classes[] = {\n";
  2795. output_files "#ifdef HXCPP_DEBUGGER\n";
  2796. List.iter ( fun object_def ->
  2797. (match object_def with
  2798. | TClassDecl class_def when is_extern_class class_def -> ( )
  2799. | TClassDecl class_def when class_def.cl_interface -> ( )
  2800. | TClassDecl class_def ->
  2801. output_files ((const_char_star (join_class_path class_def.cl_path "." )) ^ ",\n")
  2802. | _ -> ( )
  2803. )
  2804. ) types;
  2805. output_files "#endif\n";
  2806. output_files " 0 };\n";
  2807. output_files "} // namespace hx\n";
  2808. output_files "void __files__boot() { __hxcpp_set_debugger_info(hx::__hxcpp_all_classes, hx::__hxcpp_all_files_fullpath); }\n";
  2809. files_file#close;;
  2810. let begin_header_file output_h def_string =
  2811. output_h ("#ifndef INCLUDED_" ^ def_string ^ "\n");
  2812. output_h ("#define INCLUDED_" ^ def_string ^ "\n\n");
  2813. output_h "#ifndef HXCPP_H\n";
  2814. output_h "#include <hxcpp.h>\n";
  2815. output_h "#endif\n\n";;
  2816. let end_header_file output_h def_string =
  2817. output_h ("\n#endif /* INCLUDED_" ^ def_string ^ " */ \n");;
  2818. let new_placed_cpp_file common_ctx class_path =
  2819. let base_dir = common_ctx.file in
  2820. if (Common.defined common_ctx Define.Vcproj ) then begin
  2821. make_class_directories base_dir ("src"::[]);
  2822. cached_source_writer common_ctx
  2823. ( base_dir ^ "/src/" ^ ( String.concat "-" (fst class_path) ) ^ "-" ^
  2824. (snd class_path) ^ (source_file_extension common_ctx) )
  2825. end else
  2826. new_cpp_file common_ctx common_ctx.file class_path;;
  2827. let generate_enum_files common_ctx enum_def super_deps meta file_info =
  2828. let class_path = enum_def.e_path in
  2829. let just_class_name = (snd class_path) in
  2830. let class_name = just_class_name ^ "_obj" in
  2831. let remap_class_name = ("::" ^ (join_class_path_remap class_path "::") ) in
  2832. (*let cpp_file = new_cpp_file common_ctx.file class_path in*)
  2833. let cpp_file = new_placed_cpp_file common_ctx class_path in
  2834. let output_cpp = (cpp_file#write) in
  2835. let debug = if (has_meta_key enum_def.e_meta Meta.NoDebug) || ( Common.defined common_ctx Define.NoDebug)
  2836. then 0 else 1 in
  2837. let ctx = new_context common_ctx cpp_file debug file_info in
  2838. if (debug>1) then
  2839. print_endline ("Found enum definition:" ^ (join_class_path class_path "::" ));
  2840. output_cpp "#include <hxcpp.h>\n\n";
  2841. let referenced = find_referenced_types common_ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false false false in
  2842. List.iter (add_include cpp_file) referenced;
  2843. gen_open_namespace output_cpp class_path;
  2844. output_cpp "\n";
  2845. PMap.iter (fun _ constructor ->
  2846. let name = keyword_remap constructor.ef_name in
  2847. match constructor.ef_type with
  2848. | TFun (args,_) ->
  2849. output_cpp (remap_class_name ^ " " ^ class_name ^ "::" ^ name ^ "(" ^
  2850. (gen_tfun_arg_list args) ^")\n");
  2851. output_cpp ("{\n\treturn hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^
  2852. (string_of_int constructor.ef_index) ^ ",hx::DynamicArray(0," ^
  2853. (string_of_int (List.length args)) ^ ")" );
  2854. List.iter (fun (arg,_,_) -> output_cpp (".Add(" ^ (keyword_remap arg) ^ ")")) args;
  2855. output_cpp ");\n}\n\n"
  2856. | _ ->
  2857. output_cpp ( remap_class_name ^ " " ^ class_name ^ "::" ^ name ^ ";\n\n" )
  2858. ) enum_def.e_constrs;
  2859. output_cpp ("HX_DEFINE_CREATE_ENUM(" ^ class_name ^ ")\n\n");
  2860. output_cpp ("int " ^ class_name ^ "::__FindIndex(::String inName)\n{\n");
  2861. PMap.iter (fun _ constructor ->
  2862. let name = constructor.ef_name in
  2863. let idx = string_of_int constructor.ef_index in
  2864. output_cpp ("\tif (inName==" ^ (str name) ^ ") return " ^ idx ^ ";\n") ) enum_def.e_constrs;
  2865. output_cpp ("\treturn super::__FindIndex(inName);\n");
  2866. output_cpp ("}\n\n");
  2867. let constructor_arg_count constructor =
  2868. (match constructor.ef_type with | TFun(args,_) -> List.length args | _ -> 0 )
  2869. in
  2870. (* Dynamic versions of constructors *)
  2871. let dump_dynamic_constructor _ constr =
  2872. let count = constructor_arg_count constr in
  2873. if (count>0) then begin
  2874. let nargs = string_of_int count in
  2875. output_cpp ("STATIC_HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^
  2876. (keyword_remap constr.ef_name) ^ ",return)\n\n");
  2877. end
  2878. in
  2879. PMap.iter dump_dynamic_constructor enum_def.e_constrs;
  2880. output_cpp ("int " ^ class_name ^ "::__FindArgCount(::String inName)\n{\n");
  2881. PMap.iter (fun _ constructor ->
  2882. let name = constructor.ef_name in
  2883. let count = string_of_int (constructor_arg_count constructor) in
  2884. output_cpp ("\tif (inName==" ^ (str name) ^ ") return " ^ count ^ ";\n") ) enum_def.e_constrs;
  2885. output_cpp ("\treturn super::__FindArgCount(inName);\n");
  2886. output_cpp ("}\n\n");
  2887. (* Dynamic "Get" Field function - string version *)
  2888. output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName,hx::PropertyAccess inCallProp)\n{\n");
  2889. let dump_constructor_test _ constr =
  2890. output_cpp ("\tif (inName==" ^ (str constr.ef_name) ^ ") return " ^
  2891. (keyword_remap constr.ef_name) );
  2892. if ( (constructor_arg_count constr) > 0 ) then output_cpp "_dyn()";
  2893. output_cpp (";\n")
  2894. in
  2895. PMap.iter dump_constructor_test enum_def.e_constrs;
  2896. output_cpp ("\treturn super::__Field(inName,inCallProp);\n}\n\n");
  2897. output_cpp "static ::String sStaticFields[] = {\n";
  2898. let sorted =
  2899. List.sort (fun f1 f2 -> (PMap.find f1 enum_def.e_constrs ).ef_index -
  2900. (PMap.find f2 enum_def.e_constrs ).ef_index )
  2901. (pmap_keys enum_def.e_constrs) in
  2902. List.iter (fun name -> output_cpp ("\t" ^ (str name) ^ ",\n") ) sorted;
  2903. output_cpp "\t::String(null())\n};\n\n";
  2904. (* ENUM - Mark static as used by GC *)
  2905. output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n";
  2906. PMap.iter (fun _ constructor ->
  2907. let name = keyword_remap constructor.ef_name in
  2908. match constructor.ef_type with
  2909. | TFun (_,_) -> ()
  2910. | _ -> output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") )
  2911. enum_def.e_constrs;
  2912. output_cpp "};\n\n";
  2913. (* ENUM - Visit static as used by GC *)
  2914. output_cpp "#ifdef HXCPP_VISIT_ALLOCS\n";
  2915. output_cpp "static void sVisitStatic(HX_VISIT_PARAMS) {\n";
  2916. output_cpp ("\tHX_VISIT_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n");
  2917. PMap.iter (fun _ constructor ->
  2918. let name = keyword_remap constructor.ef_name in
  2919. match constructor.ef_type with
  2920. | TFun (_,_) -> ()
  2921. | _ -> output_cpp ("\tHX_VISIT_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") )
  2922. enum_def.e_constrs;
  2923. output_cpp "};\n";
  2924. output_cpp "#endif\n\n";
  2925. output_cpp "static ::String sMemberFields[] = { ::String(null()) };\n";
  2926. output_cpp ("hx::Class " ^ class_name ^ "::__mClass;\n\n");
  2927. output_cpp ("Dynamic __Create_" ^ class_name ^ "() { return new " ^ class_name ^ "; }\n\n");
  2928. output_cpp ("void " ^ class_name ^ "::__register()\n{\n");
  2929. let text_name = str (join_class_path class_path ".") in
  2930. output_cpp ("\nhx::Static(__mClass) = hx::RegisterClass(" ^ text_name ^
  2931. ", hx::TCanCast< " ^ class_name ^ " >,sStaticFields,sMemberFields,\n");
  2932. output_cpp ("\t&__Create_" ^ class_name ^ ", &__Create,\n");
  2933. output_cpp ("\t&super::__SGetClass(), &Create" ^ class_name ^ ", sMarkStatics\n");
  2934. output_cpp("#ifdef HXCPP_VISIT_ALLOCS\n , sVisitStatic\n#endif\n");
  2935. output_cpp ("#ifdef HXCPP_SCRIPTABLE\n , 0\n#endif\n");
  2936. output_cpp (");\n}\n\n");
  2937. output_cpp ("void " ^ class_name ^ "::__boot()\n{\n");
  2938. (match meta with
  2939. | Some expr ->
  2940. let ctx = new_context common_ctx cpp_file 1 file_info in
  2941. gen_expression_tree ctx true expr "__mClass->__meta__ = " ";\n";
  2942. | _ -> () );
  2943. PMap.iter (fun _ constructor ->
  2944. let name = constructor.ef_name in
  2945. match constructor.ef_type with
  2946. | TFun (_,_) -> ()
  2947. | _ ->
  2948. output_cpp ( "hx::Static(" ^ (keyword_remap name) ^ ") = hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^
  2949. (string_of_int constructor.ef_index) ^ ");\n" )
  2950. ) enum_def.e_constrs;
  2951. output_cpp ("}\n\n");
  2952. output_cpp "\n";
  2953. gen_close_namespace output_cpp class_path;
  2954. cpp_file#close;
  2955. let h_file = new_header_file common_ctx common_ctx.file class_path in
  2956. let super = "hx::EnumBase_obj" in
  2957. let output_h = (h_file#write) in
  2958. let def_string = join_class_path class_path "_" in
  2959. ctx.ctx_output <- output_h;
  2960. begin_header_file output_h def_string;
  2961. List.iter (gen_forward_decl h_file ) referenced;
  2962. gen_open_namespace output_h class_path;
  2963. output_h "\n\n";
  2964. output_h ("class " ^ class_name ^ " : public " ^ super ^ "\n");
  2965. output_h ("{\n\ttypedef " ^ super ^ " super;\n");
  2966. output_h ("\t\ttypedef " ^ class_name ^ " OBJ_;\n");
  2967. output_h "\n\tpublic:\n";
  2968. output_h ("\t\t" ^ class_name ^ "() {};\n");
  2969. output_h ("\t\tHX_DO_ENUM_RTTI;\n");
  2970. output_h ("\t\tstatic void __boot();\n");
  2971. output_h ("\t\tstatic void __register();\n");
  2972. output_h ("\t\t::String GetEnumName( ) const { return " ^
  2973. (str (join_class_path class_path ".")) ^ "; }\n" );
  2974. output_h ("\t\t::String __ToString() const { return " ^
  2975. (str (just_class_name ^ ".") )^ " + tag; }\n\n");
  2976. PMap.iter (fun _ constructor ->
  2977. let name = keyword_remap constructor.ef_name in
  2978. output_h ( "\t\tstatic " ^ remap_class_name ^ " " ^ name );
  2979. match constructor.ef_type with
  2980. | TFun (args,_) ->
  2981. output_h ( "(" ^ (gen_tfun_arg_list args) ^");\n");
  2982. output_h ( "\t\tstatic Dynamic " ^ name ^ "_dyn();\n");
  2983. | _ ->
  2984. output_h ";\n";
  2985. output_h ( "\t\tstatic inline " ^ remap_class_name ^ " " ^ name ^
  2986. "_dyn() { return " ^name ^ "; }\n" );
  2987. ) enum_def.e_constrs;
  2988. output_h "};\n\n";
  2989. gen_close_namespace output_h class_path;
  2990. end_header_file output_h def_string;
  2991. h_file#close;
  2992. let depend_referenced = find_referenced_types common_ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false true false in
  2993. depend_referenced;;
  2994. let list_iteri func in_list =
  2995. let idx = ref 0 in
  2996. List.iter (fun elem -> func !idx elem; idx := !idx + 1 ) in_list
  2997. ;;
  2998. let has_new_gc_references class_def =
  2999. match class_def.cl_dynamic with
  3000. | Some _ -> true
  3001. | _ -> (
  3002. let is_gc_reference field =
  3003. (should_implement_field field) && (is_data_member field) &&
  3004. match type_string field.cf_type with
  3005. | "bool" | "int" | "Float" -> false
  3006. | _ -> true
  3007. in
  3008. List.exists is_gc_reference class_def.cl_ordered_fields
  3009. )
  3010. ;;
  3011. let rec has_gc_references class_def =
  3012. ( match class_def.cl_super with
  3013. | Some def when has_gc_references (fst def) -> true
  3014. | _ -> false )
  3015. || has_new_gc_references class_def
  3016. ;;
  3017. let rec find_next_super_iteration class_def =
  3018. match class_def.cl_super with
  3019. | Some (klass,params) when has_new_gc_references klass -> class_string klass "_obj" params true
  3020. | Some (klass,_) -> find_next_super_iteration klass
  3021. | _ -> "";
  3022. ;;
  3023. let has_init_field class_def =
  3024. match class_def.cl_init with
  3025. | Some _ -> true
  3026. | _ -> false;;
  3027. let is_abstract_impl class_def = match class_def.cl_kind with
  3028. | KAbstractImpl _ -> true
  3029. | _ -> false
  3030. ;;
  3031. let variable_field field =
  3032. (match field.cf_expr with
  3033. | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field
  3034. | _ -> true)
  3035. ;;
  3036. let is_readable class_def field =
  3037. (match field.cf_kind with
  3038. | Var { v_read = AccNever } when (is_extern_field field) -> false
  3039. | Var { v_read = AccInline } -> false
  3040. | Var _ when is_abstract_impl class_def -> false
  3041. | _ -> true)
  3042. ;;
  3043. let is_writable class_def field =
  3044. (match field.cf_kind with
  3045. | Var { v_write = AccNever } when (is_extern_field field) -> false
  3046. | Var { v_read = AccInline } -> false
  3047. | Var _ when is_abstract_impl class_def -> false
  3048. | _ -> true)
  3049. ;;
  3050. let statics_except_meta class_def = (List.filter (fun static -> static.cf_name <> "__meta__" && static.cf_name <> "__rtti") class_def.cl_ordered_statics);;
  3051. let has_set_member_field class_def =
  3052. implement_dynamic_here class_def || (
  3053. let reflect_fields = List.filter (reflective class_def) (class_def.cl_ordered_fields) in
  3054. let reflect_writable = List.filter (is_writable class_def) reflect_fields in
  3055. List.exists variable_field reflect_writable
  3056. )
  3057. ;;
  3058. let has_set_static_field class_def =
  3059. let reflect_fields = List.filter (reflective class_def) (statics_except_meta class_def) in
  3060. let reflect_writable = List.filter (is_writable class_def) reflect_fields in
  3061. List.exists variable_field reflect_writable
  3062. ;;
  3063. let has_get_fields class_def =
  3064. implement_dynamic_here class_def || (
  3065. let is_data_field field = (match follow field.cf_type with | TFun _ -> false | _ -> true) in
  3066. List.exists is_data_field class_def.cl_ordered_fields
  3067. )
  3068. ;;
  3069. let has_get_member_field class_def =
  3070. implement_dynamic_here class_def || (
  3071. let reflect_fields = List.filter (reflective class_def) (class_def.cl_ordered_fields) in
  3072. List.exists (is_readable class_def) reflect_fields
  3073. )
  3074. ;;
  3075. let has_get_static_field class_def =
  3076. let reflect_fields = List.filter (reflective class_def) (statics_except_meta class_def) in
  3077. List.exists (is_readable class_def) reflect_fields
  3078. ;;
  3079. let has_boot_field class_def =
  3080. List.exists has_field_init (List.filter should_implement_field class_def.cl_ordered_statics);
  3081. ;;
  3082. let is_macro meta =
  3083. Meta.has Meta.Macro meta
  3084. ;;
  3085. let access_str a = match a with
  3086. | AccNormal -> "AccNormal"
  3087. | AccNo -> "AccNo"
  3088. | AccNever -> "AccNever"
  3089. | AccResolve -> "AccResolve"
  3090. | AccCall -> "AccCall"
  3091. | AccInline -> "AccInline"
  3092. | AccRequire(_,_) -> "AccRequire" ;;
  3093. let generate_class_files common_ctx member_types super_deps constructor_deps class_def file_info inScriptable =
  3094. let class_path = class_def.cl_path in
  3095. let nativeGen = has_meta_key class_def.cl_meta Meta.NativeGen in
  3096. let class_name = (snd class_path) ^ (if nativeGen then "" else "_obj") in
  3097. let dot_name = join_class_path class_path "." in
  3098. let smart_class_name = (snd class_path) in
  3099. (*let cpp_file = new_cpp_file common_ctx.file class_path in*)
  3100. let cpp_file = new_placed_cpp_file common_ctx class_path in
  3101. let output_cpp = (cpp_file#write) in
  3102. let debug = if (has_meta_key class_def.cl_meta Meta.NoDebug) || ( Common.defined common_ctx Define.NoDebug)
  3103. then 0 else 1 in
  3104. let scriptable = inScriptable && not class_def.cl_private in
  3105. let ctx = new_context common_ctx cpp_file debug file_info in
  3106. ctx.ctx_class_name <- "::" ^ (join_class_path class_def.cl_path "::");
  3107. ctx.ctx_class_super_name <- (match class_def.cl_super with
  3108. | Some (klass, params) -> class_string klass "_obj" params true
  3109. | _ -> "");
  3110. ctx.ctx_class_member_types <- member_types;
  3111. if (debug>1) then print_endline ("Found class definition:" ^ ctx.ctx_class_name);
  3112. let ptr_name = "hx::ObjectPtr< " ^ class_name ^ " >" in
  3113. let constructor_arg_var_list =
  3114. match class_def.cl_constructor with
  3115. | Some definition ->
  3116. (match definition.cf_expr with
  3117. | Some { eexpr = TFunction function_def } ->
  3118. List.map (fun (v,o) -> (v.v_name, gen_arg_type_name v.v_name o v.v_type "__o_"))
  3119. function_def.tf_args;
  3120. | _ ->
  3121. (match follow definition.cf_type with
  3122. | TFun (args,_) -> List.map (fun (a,_,t) -> (a, (type_string t, a)) ) args
  3123. | _ -> [])
  3124. )
  3125. | _ -> [] in
  3126. let constructor_type_var_list =
  3127. List.map snd constructor_arg_var_list in
  3128. let constructor_var_list = List.map snd constructor_type_var_list in
  3129. let constructor_type_args = String.concat ","
  3130. (List.map (fun (t,a) -> t ^ " " ^ a) constructor_type_var_list) in
  3131. let constructor_args = String.concat "," constructor_var_list in
  3132. let implement_dynamic = implement_dynamic_here class_def in
  3133. output_cpp "#include <hxcpp.h>\n\n";
  3134. let force_field = scriptable && (has_get_member_field class_def) in
  3135. let field_integer_dynamic = force_field || (has_field_integer_lookup class_def) in
  3136. let field_integer_numeric = force_field || (has_field_integer_numeric_lookup class_def) in
  3137. let all_referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps constructor_deps false false scriptable in
  3138. List.iter ( add_include cpp_file ) all_referenced;
  3139. let dynamic_interface_closures = (Common.defined common_ctx Define.DynamicInterfaceClosures) in
  3140. (* All interfaces (and sub-interfaces) implemented *)
  3141. let implemented_hash = Hashtbl.create 0 in
  3142. List.iter (fun imp ->
  3143. let rec descend_interface interface =
  3144. let imp_path = (fst interface).cl_path in
  3145. let interface_name = "::" ^ (join_class_path_remap imp_path "::" ) in
  3146. if ( not (Hashtbl.mem implemented_hash interface_name) ) then begin
  3147. Hashtbl.add implemented_hash interface_name ();
  3148. List.iter descend_interface (fst interface).cl_implements;
  3149. end;
  3150. match (fst interface).cl_super with
  3151. | Some (interface,params) -> descend_interface (interface,params)
  3152. | _ -> ()
  3153. in descend_interface imp
  3154. ) (real_interfaces class_def.cl_implements);
  3155. let implemented = hash_keys implemented_hash in
  3156. if (scriptable) then
  3157. output_cpp "#include <hx/Scriptable.h>\n";
  3158. output_cpp ( get_class_code class_def Meta.CppFileCode );
  3159. let inc = get_meta_string_path class_def.cl_meta Meta.CppInclude in
  3160. if (inc<>"") then
  3161. output_cpp ("#include \"" ^ inc ^ "\"\n");
  3162. gen_open_namespace output_cpp class_path;
  3163. output_cpp "\n";
  3164. output_cpp ( get_class_code class_def Meta.CppNamespaceCode );
  3165. if (not class_def.cl_interface) && not nativeGen then begin
  3166. output_cpp ("void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")\n{\n");
  3167. (match class_def.cl_constructor with
  3168. | Some definition ->
  3169. (match definition.cf_expr with
  3170. | Some { eexpr = TFunction function_def } ->
  3171. if has_meta_key definition.cf_meta Meta.NoDebug then ctx.ctx_debug_level <- 0;
  3172. if ctx.ctx_debug_level >0 then begin
  3173. hx_stack_push ctx output_cpp dot_name "new" function_def.tf_expr.epos;
  3174. output_cpp "HX_STACK_THIS(this)\n";
  3175. List.iter (fun (a,(t,o)) -> output_cpp ("HX_STACK_ARG(" ^ (keyword_remap o) ^ ",\"" ^ a ^"\")\n") ) constructor_arg_var_list;
  3176. end;
  3177. if (has_default_values function_def.tf_args) then begin
  3178. generate_default_values ctx function_def.tf_args "__o_";
  3179. end;
  3180. let oldVoid = ctx.ctx_real_void in
  3181. ctx.ctx_real_void <- true;
  3182. gen_expression_tree ctx false (mk_block function_def.tf_expr) "" "";
  3183. cpp_file#terminate_line;
  3184. ctx.ctx_real_void <- oldVoid;
  3185. ctx.ctx_debug_level <- debug;
  3186. | _ -> ()
  3187. )
  3188. | _ -> ());
  3189. output_cpp "}\n\n";
  3190. (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *)
  3191. output_cpp ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " ^ class_name ^ "; }\n\n");
  3192. output_cpp (ptr_name ^ " " ^ class_name ^ "::__new(" ^constructor_type_args ^")\n");
  3193. let create_result () =
  3194. output_cpp ("{\n\t" ^ ptr_name ^ " _result_ = new " ^ class_name ^ "();\n");
  3195. in
  3196. create_result ();
  3197. output_cpp ("\t_result_->__construct(" ^ constructor_args ^ ");\n");
  3198. output_cpp ("\treturn _result_;\n}\n\n");
  3199. output_cpp ("Dynamic " ^ class_name ^ "::__Create(hx::DynamicArray inArgs)\n");
  3200. create_result ();
  3201. output_cpp ("\t_result_->__construct(" ^ (array_arg_list constructor_var_list) ^ ");\n");
  3202. output_cpp ("\treturn _result_;\n}\n\n");
  3203. if ( (List.length implemented) > 0 ) then begin
  3204. output_cpp ("hx::Object *" ^ class_name ^ "::__ToInterface(const hx::type_info &inType)\n{\n");
  3205. List.iter (fun interface_name ->
  3206. output_cpp ("\tif (inType==typeid( " ^ interface_name ^ "_obj)) " ^
  3207. "return operator " ^ interface_name ^ "_obj *();\n");
  3208. ) implemented;
  3209. output_cpp ("\treturn super::__ToInterface(inType);\n}\n\n");
  3210. List.iter (fun interface_name ->
  3211. output_cpp (class_name ^ "::operator " ^ interface_name ^ "_obj *() { " ^
  3212. "return new " ^ interface_name ^ "_delegate_< " ^ class_name ^" >(this); }\n\n" );
  3213. ) implemented;
  3214. end;
  3215. end;
  3216. (match class_def.cl_init with
  3217. | Some expression ->
  3218. output_cpp ("void " ^ class_name^ "::__init__() {\n");
  3219. hx_stack_push ctx output_cpp dot_name "__init__" expression.epos;
  3220. gen_expression_tree (new_context common_ctx cpp_file debug file_info) false (mk_block expression) "" "";
  3221. output_cpp "}\n\n";
  3222. | _ -> ());
  3223. let statics_except_meta = statics_except_meta class_def in
  3224. let implemented_fields = List.filter should_implement_field statics_except_meta in
  3225. let dump_field_name = (fun field -> output_cpp ("\t" ^ (str field.cf_name) ^ ",\n")) in
  3226. let implemented_instance_fields = List.filter should_implement_field class_def.cl_ordered_fields in
  3227. List.iter
  3228. (gen_field ctx class_def class_name smart_class_name dot_name false class_def.cl_interface)
  3229. class_def.cl_ordered_fields;
  3230. List.iter
  3231. (gen_field ctx class_def class_name smart_class_name dot_name true class_def.cl_interface) statics_except_meta;
  3232. output_cpp "\n";
  3233. let override_iteration = (not nativeGen) && (has_new_gc_references class_def) in
  3234. (* Initialise non-static variables *)
  3235. if ( (not class_def.cl_interface) && (not nativeGen) ) then begin
  3236. output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n");
  3237. if (implement_dynamic) then
  3238. output_cpp "\tHX_INIT_IMPLEMENT_DYNAMIC;\n";
  3239. List.iter
  3240. (fun field -> let remap_name = keyword_remap field.cf_name in
  3241. match field.cf_expr with
  3242. | Some { eexpr = TFunction function_def } ->
  3243. if (is_dynamic_haxe_method field) then
  3244. output_cpp ("\t" ^ remap_name ^ " = new __default_" ^ remap_name ^ "(this);\n")
  3245. | _ -> ()
  3246. )
  3247. class_def.cl_ordered_fields;
  3248. output_cpp "}\n\n";
  3249. let dump_field_iterator macro field =
  3250. if (is_data_member field) then begin
  3251. let remap_name = keyword_remap field.cf_name in
  3252. output_cpp ("\t" ^ macro ^ "(" ^ remap_name ^ ",\"" ^ field.cf_name^ "\");\n");
  3253. (match field.cf_kind with Var { v_read = AccCall } when (is_dynamic_accessor ("get_" ^ field.cf_name) "get" field class_def) ->
  3254. let name = "get_" ^ field.cf_name in
  3255. output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ());
  3256. (match field.cf_kind with Var { v_write = AccCall } when (is_dynamic_accessor ("set_" ^ field.cf_name) "set" field class_def) ->
  3257. let name = "set_" ^ field.cf_name in
  3258. output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ());
  3259. end
  3260. in
  3261. if (override_iteration) then begin
  3262. let super_needs_iteration = find_next_super_iteration class_def in
  3263. (* MARK function - explicitly mark all child pointers *)
  3264. output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n");
  3265. output_cpp ("\tHX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n");
  3266. if (implement_dynamic) then
  3267. output_cpp "\tHX_MARK_DYNAMIC;\n";
  3268. List.iter (dump_field_iterator "HX_MARK_MEMBER_NAME") implemented_instance_fields;
  3269. (match super_needs_iteration with
  3270. | "" -> ()
  3271. | super -> output_cpp ("\t" ^ super^"::__Mark(HX_MARK_ARG);\n" ) );
  3272. output_cpp "\tHX_MARK_END_CLASS();\n";
  3273. output_cpp "}\n\n";
  3274. (* Visit function - explicitly visit all child pointers *)
  3275. output_cpp ("void " ^ class_name ^ "::__Visit(HX_VISIT_PARAMS)\n{\n");
  3276. if (implement_dynamic) then
  3277. output_cpp "\tHX_VISIT_DYNAMIC;\n";
  3278. List.iter (dump_field_iterator "HX_VISIT_MEMBER_NAME") implemented_instance_fields;
  3279. (match super_needs_iteration with
  3280. | "" -> ()
  3281. | super -> output_cpp ("\t" ^ super ^ "::__Visit(HX_VISIT_ARG);\n") );
  3282. output_cpp "}\n\n";
  3283. end;
  3284. let reflect_member_fields = List.filter (reflective class_def) class_def.cl_ordered_fields in
  3285. let reflect_member_readable = List.filter (is_readable class_def) reflect_member_fields in
  3286. let reflect_member_writable = List.filter (is_writable class_def) reflect_member_fields in
  3287. let reflect_write_member_variables = List.filter variable_field reflect_member_writable in
  3288. let reflect_static_fields = List.filter (reflective class_def) (statics_except_meta) in
  3289. let reflect_static_readable = List.filter (is_readable class_def) reflect_static_fields in
  3290. let reflect_static_writable = List.filter (is_writable class_def) reflect_static_fields in
  3291. let reflect_write_static_variables = List.filter variable_field reflect_static_writable in
  3292. let dump_quick_field_test fields =
  3293. if ( (List.length fields) > 0) then begin
  3294. let len = function (_,l,_) -> l in
  3295. let sfields = List.sort (fun f1 f2 -> (len f1)-(len f2)) fields in
  3296. let len_case = ref (-1) in
  3297. output_cpp "\tswitch(inName.length) {\n";
  3298. List.iter (fun (field,l,result) ->
  3299. if (l <> !len_case) then begin
  3300. if (!len_case>=0) then output_cpp "\t\tbreak;\n";
  3301. output_cpp ("\tcase " ^ (string_of_int l) ^ ":\n");
  3302. len_case := l;
  3303. end;
  3304. output_cpp ("\t\tif (HX_FIELD_EQ(inName,\"" ^ (Ast.s_escape field) ^ "\") ) { " ^ result ^ " }\n");
  3305. ) sfields;
  3306. output_cpp "\t}\n";
  3307. end;
  3308. in
  3309. let checkPropCall field = if ( (has_meta_key class_def.cl_meta Meta.NativeProperty) ||
  3310. (has_meta_key field.cf_meta Meta.NativeProperty) ||
  3311. (Common.defined common_ctx Define.ForceNativeProperty) )
  3312. then
  3313. "inCallProp != hx::paccNever"
  3314. else
  3315. "inCallProp == hx::paccAlways"
  3316. in
  3317. if (has_get_member_field class_def) then begin
  3318. (* Dynamic "Get" Field function - string version *)
  3319. output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName,hx::PropertyAccess inCallProp)\n{\n");
  3320. let get_field_dat = List.map (fun f ->
  3321. (f.cf_name, String.length f.cf_name,
  3322. (match f.cf_kind with
  3323. | Var { v_read = AccCall } when is_extern_field f -> "if (" ^ (checkPropCall f) ^ ") return " ^(keyword_remap ("get_" ^ f.cf_name)) ^ "()"
  3324. | Var { v_read = AccCall } -> "return " ^ (checkPropCall f) ^ " ? " ^ (keyword_remap ("get_" ^ f.cf_name)) ^ "() : " ^
  3325. ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()")
  3326. | _ -> "return " ^ ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()")
  3327. ) ^ ";"
  3328. ) )
  3329. in
  3330. dump_quick_field_test (get_field_dat reflect_member_readable);
  3331. if (implement_dynamic) then
  3332. output_cpp "\tHX_CHECK_DYNAMIC_GET_FIELD(inName);\n";
  3333. output_cpp ("\treturn super::__Field(inName,inCallProp);\n}\n\n");
  3334. (* Dynamic "Get" Field function - int version *)
  3335. if ( field_integer_numeric || field_integer_dynamic) then begin
  3336. let dump_static_ids = (fun field ->
  3337. let remap_name = keyword_remap field.cf_name in
  3338. output_cpp ("static int __id_" ^ remap_name ^ " = __hxcpp_field_to_id(\"" ^
  3339. (field.cf_name) ^ "\");\n");
  3340. ) in
  3341. List.iter dump_static_ids reflect_member_readable;
  3342. output_cpp "\n\n";
  3343. let output_ifield return_type function_name all_fields =
  3344. output_cpp (return_type ^" " ^ class_name ^ "::" ^ function_name ^ "(int inFieldID)\n{\n");
  3345. let dump_field_test = (fun f ->
  3346. let remap_name = keyword_remap f.cf_name in
  3347. output_cpp ("\tif (inFieldID==__id_" ^ remap_name ^ ") return " ^
  3348. ( if (return_type="Float") then "hx::ToDouble( " else "" ) ^
  3349. (match f.cf_kind with
  3350. | Var { v_read = AccCall } -> (keyword_remap ("get_" ^ f.cf_name)) ^ "()"
  3351. | _ -> (remap_name ^ if ( variable_field f) then "" else "_dyn()")
  3352. ) ^ ( if (return_type="Float") then " ) " else "" ) ^ ";\n");
  3353. ) in
  3354. List.iter dump_field_test (List.filter (fun f -> all_fields || (is_numeric_field f)) reflect_member_readable);
  3355. if (implement_dynamic) then
  3356. output_cpp "\tHX_CHECK_DYNAMIC_GET_INT_FIELD(inFieldID);\n";
  3357. output_cpp ("\treturn super::" ^ function_name ^ "(inFieldID);\n}\n\n");
  3358. in
  3359. if (field_integer_dynamic) then output_ifield "Dynamic" "__IField" true;
  3360. if (field_integer_numeric) then output_ifield "double" "__INumField" false;
  3361. end;
  3362. end;
  3363. if (has_get_static_field class_def) then begin
  3364. output_cpp ("bool " ^ class_name ^ "::__GetStatic(const ::String &inName, Dynamic &outValue, hx::PropertyAccess inCallProp)\n{\n");
  3365. let get_field_dat = List.map (fun f ->
  3366. (f.cf_name, String.length f.cf_name,
  3367. (match f.cf_kind with
  3368. | Var { v_read = AccCall } when is_extern_field f -> "if (" ^ (checkPropCall f) ^ ") { outValue = " ^(keyword_remap ("get_" ^ f.cf_name)) ^ "(); return true; }"
  3369. | Var { v_read = AccCall } -> "outValue = " ^ (checkPropCall f) ^ " ? " ^ (keyword_remap ("get_" ^ f.cf_name)) ^ "() : " ^
  3370. ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()") ^ "; return true;";
  3371. | _ -> "outValue = " ^ ((keyword_remap f.cf_name) ^ (if (variable_field f) then "" else "_dyn()") ^ "; return true;")
  3372. )
  3373. ) )
  3374. in
  3375. dump_quick_field_test (get_field_dat reflect_static_readable);
  3376. output_cpp ("\treturn false;\n}\n\n");
  3377. end;
  3378. (* Dynamic "Set" Field function *)
  3379. if (has_set_member_field class_def) then begin
  3380. output_cpp ("Dynamic " ^ class_name ^ "::__SetField(const ::String &inName,const Dynamic &inValue,hx::PropertyAccess inCallProp)\n{\n");
  3381. let set_field_dat = List.map (fun f ->
  3382. let default_action =
  3383. (keyword_remap f.cf_name) ^ "=inValue.Cast< " ^ (type_string f.cf_type) ^ " >();" ^
  3384. " return inValue;" in
  3385. (f.cf_name, String.length f.cf_name,
  3386. (match f.cf_kind with
  3387. | Var { v_write = AccCall } -> "if (" ^ (checkPropCall f) ^ ") return " ^ (keyword_remap ("set_" ^ f.cf_name)) ^ "(inValue);"
  3388. ^ ( if is_extern_field f then "" else default_action )
  3389. | _ -> default_action
  3390. )
  3391. )
  3392. ) in
  3393. dump_quick_field_test (set_field_dat reflect_write_member_variables);
  3394. if (implement_dynamic) then begin
  3395. output_cpp ("\ttry { return super::__SetField(inName,inValue,inCallProp); }\n");
  3396. output_cpp ("\tcatch(Dynamic e) { HX_DYNAMIC_SET_FIELD(inName,inValue); }\n");
  3397. output_cpp "\treturn inValue;\n}\n\n";
  3398. end else
  3399. output_cpp ("\treturn super::__SetField(inName,inValue,inCallProp);\n}\n\n");
  3400. end;
  3401. if (has_set_static_field class_def) then begin
  3402. output_cpp ("bool " ^ class_name ^ "::__SetStatic(const ::String &inName,Dynamic &ioValue,hx::PropertyAccess inCallProp)\n{\n");
  3403. let set_field_dat = List.map (fun f ->
  3404. let default_action =
  3405. (keyword_remap f.cf_name) ^ "=ioValue.Cast< " ^ (type_string f.cf_type) ^ " >(); return true;" in
  3406. (f.cf_name, String.length f.cf_name,
  3407. (match f.cf_kind with
  3408. | Var { v_write = AccCall } -> "if (" ^ (checkPropCall f) ^ ") ioValue = " ^ (keyword_remap ("set_" ^ f.cf_name)) ^ "(ioValue);"
  3409. ^ ( if is_extern_field f then "" else " else " ^ default_action )
  3410. | _ -> default_action
  3411. )
  3412. )
  3413. ) in
  3414. dump_quick_field_test (set_field_dat reflect_write_static_variables);
  3415. output_cpp ("\treturn false;\n}\n\n");
  3416. end;
  3417. (* For getting a list of data members (eg, for serialization) *)
  3418. if (has_get_fields class_def) then begin
  3419. let append_field =
  3420. (fun field -> output_cpp ("\toutFields->push(" ^( str field.cf_name )^ ");\n")) in
  3421. let is_data_field field = (match follow field.cf_type with | TFun _ -> false | _ -> true) in
  3422. output_cpp ("void " ^ class_name ^ "::__GetFields(Array< ::String> &outFields)\n{\n");
  3423. List.iter append_field (List.filter is_data_field class_def.cl_ordered_fields);
  3424. if (implement_dynamic) then
  3425. output_cpp "\tHX_APPEND_DYNAMIC_FIELDS(outFields);\n";
  3426. output_cpp "\tsuper::__GetFields(outFields);\n";
  3427. output_cpp "};\n\n";
  3428. end;
  3429. let storage field = match type_string field.cf_type with
  3430. | "bool" -> "hx::fsBool"
  3431. | "int" -> "hx::fsInt"
  3432. | "Float" -> "hx::fsFloat"
  3433. | "::String" -> "hx::fsString"
  3434. | str -> "hx::fsObject" ^ " /*" ^ str ^ "*/ "
  3435. in
  3436. let dump_member_storage = (fun field ->
  3437. output_cpp ("\t{" ^ (storage field) ^ ",(int)offsetof(" ^ class_name ^"," ^ (keyword_remap field.cf_name) ^")," ^
  3438. (str field.cf_name) ^ "},\n")
  3439. )
  3440. in
  3441. let dump_static_storage = (fun field ->
  3442. output_cpp ("\t{" ^ (storage field) ^ ",(void *) &" ^ class_name ^"::" ^ (keyword_remap field.cf_name) ^"," ^
  3443. (str field.cf_name) ^ "},\n")
  3444. )
  3445. in
  3446. output_cpp "#if HXCPP_SCRIPTABLE\n";
  3447. let stored_fields = List.filter is_data_member implemented_instance_fields in
  3448. if ( (List.length stored_fields) > 0) then begin
  3449. output_cpp "static hx::StorageInfo sMemberStorageInfo[] = {\n";
  3450. List.iter dump_member_storage stored_fields;
  3451. output_cpp "\t{ hx::fsUnknown, 0, null()}\n};\n";
  3452. end else
  3453. output_cpp "static hx::StorageInfo *sMemberStorageInfo = 0;\n";
  3454. let stored_statics = List.filter is_data_member implemented_fields in
  3455. if ( (List.length stored_statics) > 0) then begin
  3456. output_cpp "static hx::StaticInfo sStaticStorageInfo[] = {\n";
  3457. List.iter dump_static_storage stored_statics;
  3458. output_cpp "\t{ hx::fsUnknown, 0, null()}\n};\n";
  3459. end else
  3460. output_cpp "static hx::StaticInfo *sStaticStorageInfo = 0;\n";
  3461. output_cpp "#endif\n\n";
  3462. end; (* cl_interface *)
  3463. let reflective_members = List.filter (reflective class_def) implemented_instance_fields in
  3464. let sMemberFields = if List.length reflective_members>0 then begin
  3465. output_cpp "static ::String sMemberFields[] = {\n";
  3466. List.iter dump_field_name reflective_members;
  3467. output_cpp "\t::String(null()) };\n\n";
  3468. "sMemberFields"
  3469. end else
  3470. "0 /* sMemberFields */";
  3471. in
  3472. if (not nativeGen) then begin
  3473. (* Mark static variables as used *)
  3474. output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n";
  3475. output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n");
  3476. List.iter (fun field ->
  3477. if (is_data_member field) then
  3478. output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ (keyword_remap field.cf_name) ^ ",\"" ^ field.cf_name ^ "\");\n") )
  3479. implemented_fields;
  3480. output_cpp "};\n\n";
  3481. (* Visit static variables *)
  3482. output_cpp "#ifdef HXCPP_VISIT_ALLOCS\n";
  3483. output_cpp "static void sVisitStatics(HX_VISIT_PARAMS) {\n";
  3484. output_cpp ("\tHX_VISIT_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n");
  3485. List.iter (fun field ->
  3486. if (is_data_member field) then
  3487. output_cpp ("\tHX_VISIT_MEMBER_NAME(" ^ class_name ^ "::" ^ (keyword_remap field.cf_name) ^ ",\"" ^ field.cf_name ^ "\");\n") )
  3488. implemented_fields;
  3489. output_cpp "};\n\n";
  3490. output_cpp "#endif\n\n";
  3491. end;
  3492. let script_type t optional = if optional then "Object" else
  3493. match type_string t with
  3494. | "bool" -> "Int"
  3495. | "int" -> "Int"
  3496. | "Float" -> "Float"
  3497. | "::String" -> "String"
  3498. | "Null" -> "Void"
  3499. | "Void" -> "Void"
  3500. | _ -> "Object"
  3501. in
  3502. let script_signature t optional = match script_type t optional with
  3503. | "Bool" -> "b"
  3504. | "Int" -> "i"
  3505. | "Float" -> "f"
  3506. | "String" -> "s"
  3507. | "Void" -> "v"
  3508. | _ -> "o"
  3509. in
  3510. let script_size_type t optional = match script_type t optional with
  3511. | "Object" -> "void *"
  3512. | x -> x
  3513. in
  3514. let generate_script_function isStatic field scriptName callName =
  3515. match follow field.cf_type with
  3516. | TFun (args,return_type) ->
  3517. output_cpp ("\nstatic void " ^ scriptName ^ "(hx::CppiaCtx *ctx) {\n");
  3518. let ret = script_signature return_type false in
  3519. if (ret<>"v") then output_cpp ("ctx->return" ^ (script_type return_type false) ^ "(");
  3520. if isStatic then
  3521. output_cpp (class_name ^ "::" ^ callName ^ "(")
  3522. else
  3523. output_cpp ("((" ^ class_name ^ "*)ctx->getThis())->" ^ callName ^ "(");
  3524. let (signature,_,_) = List.fold_left (fun (signature,sep,size) (_,opt,t) ->
  3525. output_cpp (sep ^ "ctx->get" ^ (script_type t opt) ^ "(" ^ size ^ ")");
  3526. (signature ^ (script_signature t opt ), ",", (size^"+sizeof(" ^ (script_size_type t opt) ^ ")") ) ) (ret,"","sizeof(void*)") args
  3527. in
  3528. output_cpp ")";
  3529. if (ret<>"v") then output_cpp (")");
  3530. output_cpp (";\n}\n");
  3531. signature;
  3532. | _ -> ""
  3533. in
  3534. if (scriptable && not nativeGen) then begin
  3535. let dump_script_field idx (field,f_args,return_t) =
  3536. let args = if (class_def.cl_interface) then
  3537. gen_tfun_interface_arg_list f_args
  3538. else
  3539. gen_tfun_arg_list f_args in
  3540. let names = List.map (fun (n,_,_) -> keyword_remap n) f_args in
  3541. let return_type = type_string return_t in
  3542. let ret = if (return_type="Void") then " " else "return " in
  3543. let name = keyword_remap field.cf_name in
  3544. let vtable = "__scriptVTable[" ^ (string_of_int (idx+1) ) ^ "] " in
  3545. let args_varray = (List.fold_left (fun l n -> l ^ ".Add(" ^ n ^ ")") "Array<Dynamic>()" names) in
  3546. output_cpp (" " ^ return_type ^ " " ^ name ^ "( " ^ args ^ " ) { ");
  3547. output_cpp ("\n\tif (" ^ vtable ^ ") {\n" );
  3548. output_cpp ("\t\thx::CppiaCtx *__ctx = hx::CppiaCtx::getCurrent();\n" );
  3549. output_cpp ("\t\thx::AutoStack __as(__ctx);\n" );
  3550. output_cpp ("\t\t__ctx->pushObject(" ^ (if class_def.cl_interface then "mDelegate.mPtr" else "this" ) ^");\n" );
  3551. List.iter (fun (name,opt, t ) ->
  3552. output_cpp ("\t\t__ctx->push" ^ (script_type t opt) ^ "(" ^ (keyword_remap name) ^ ");\n" );
  3553. ) f_args;
  3554. output_cpp ("\t\t" ^ ret ^ "__ctx->run" ^ (script_type return_t false) ^ "(" ^ vtable ^ ");\n" );
  3555. output_cpp ("\t} else " ^ ret );
  3556. if (class_def.cl_interface) then begin
  3557. output_cpp (" mDelegate->__Field(HX_CSTRING(\"" ^ field.cf_name ^ "\"), hx::paccNever)");
  3558. if (List.length names <= 5) then
  3559. output_cpp ("->__run(" ^ (String.concat "," names) ^ ");")
  3560. else
  3561. output_cpp ("->__Run(" ^ args_varray ^ ");");
  3562. end else
  3563. output_cpp (class_name ^ "::" ^ name ^ "(" ^ (String.concat "," names)^ ");");
  3564. output_cpp ("return null(); }\n");
  3565. if (class_def.cl_interface) && not dynamic_interface_closures then begin
  3566. output_cpp (" Dynamic " ^ name ^ "_dyn() { return mDelegate->__Field(HX_CSTRING(\"" ^ field.cf_name ^ "\"), hx::paccNever); }\n\n");
  3567. end
  3568. in
  3569. let not_toString = fun (field,args,_) -> field.cf_name<>"toString" || class_def.cl_interface in
  3570. let functions = List.filter not_toString (all_virtual_functions class_def) in
  3571. let new_sctipt_functions = List.filter (fun (f,_,_) -> not (is_override class_def f.cf_name) ) functions in
  3572. let sctipt_name = class_name ^ "__scriptable" in
  3573. output_cpp ("class " ^ sctipt_name ^ " : public " ^ class_name ^ " {\n" );
  3574. output_cpp (" typedef "^sctipt_name ^" __ME;\n");
  3575. output_cpp (" typedef "^class_name ^" super;\n");
  3576. let has_funky_toString = List.exists (fun f -> f.cf_name="toString") class_def.cl_ordered_statics ||
  3577. List.exists (fun f -> f.cf_name="toString" && field_arg_count f <> 0) class_def.cl_ordered_fields in
  3578. let super_string = if has_funky_toString then class_name ^ "::super" else class_name in
  3579. output_cpp (" typedef "^ super_string ^" __superString;\n");
  3580. if (class_def.cl_interface) then
  3581. output_cpp (" HX_DEFINE_SCRIPTABLE_INTERFACE\n")
  3582. else begin
  3583. output_cpp (" HX_DEFINE_SCRIPTABLE(HX_ARR_LIST" ^ (string_of_int (List.length constructor_var_list) ) ^ ")\n");
  3584. if (not implement_dynamic) then
  3585. output_cpp "\tHX_DEFINE_SCRIPTABLE_DYNAMIC;\n";
  3586. end;
  3587. list_iteri dump_script_field functions;
  3588. output_cpp ("};\n\n");
  3589. if (List.length new_sctipt_functions) > 0 then begin
  3590. let sigs = Hashtbl.create 0 in
  3591. List.iter (fun (f,_,_) ->
  3592. let s = generate_script_function false f ("__s_" ^f.cf_name) (keyword_remap f.cf_name) in
  3593. Hashtbl.add sigs f.cf_name s
  3594. ) new_sctipt_functions;
  3595. output_cpp "static hx::ScriptNamedFunction __scriptableFunctions[] = {\n";
  3596. List.iter (fun (f,_,_) ->
  3597. let s = try Hashtbl.find sigs f.cf_name with Not_found -> "v" in
  3598. output_cpp (" hx::ScriptNamedFunction(\"" ^ f.cf_name ^ "\",__s_" ^ f.cf_name ^ ",\"" ^ s ^ "\"),\n" ) ) new_sctipt_functions;
  3599. output_cpp " hx::ScriptNamedFunction(0,0,0) };\n";
  3600. end else
  3601. output_cpp "static hx::ScriptNamedFunction *__scriptableFunctions = 0;\n";
  3602. end;
  3603. let class_name_text = join_class_path class_path "." in
  3604. (* Initialise static in boot function ... *)
  3605. if (not class_def.cl_interface && not nativeGen) then begin
  3606. (* Remap the specialised "extern" classes back to the generic names *)
  3607. output_cpp ("hx::Class " ^ class_name ^ "::__mClass;\n\n");
  3608. if (scriptable) then begin
  3609. (match class_def.cl_constructor with
  3610. | Some field ->
  3611. let signature = generate_script_function false field "__script_construct_func" "__construct" in
  3612. output_cpp ("hx::ScriptFunction " ^ class_name ^ "::__script_construct(__script_construct_func,\"" ^ signature ^ "\");\n");
  3613. | _ ->
  3614. output_cpp ("hx::ScriptFunction " ^ class_name ^ "::__script_construct(0,0);\n");
  3615. );
  3616. end;
  3617. let reflective_statics = List.filter (reflective class_def) implemented_fields in
  3618. let sStaticFields = if List.length reflective_statics > 0 then begin
  3619. output_cpp "static ::String sStaticFields[] = {\n";
  3620. List.iter dump_field_name reflective_statics;
  3621. output_cpp "\t::String(null())\n};\n\n";
  3622. "sStaticFields";
  3623. end else
  3624. "0 /* sStaticFields */"
  3625. in
  3626. output_cpp ("void " ^ class_name ^ "::__register()\n{\n");
  3627. output_cpp ("\thx::Static(__mClass) = new hx::Class_obj();\n");
  3628. output_cpp ("\t__mClass->mName = " ^ (str class_name_text) ^ ";\n");
  3629. output_cpp ("\t__mClass->mSuper = &super::__SGetClass();\n");
  3630. output_cpp ("\t__mClass->mConstructEmpty = &__CreateEmpty;\n");
  3631. output_cpp ("\t__mClass->mConstructArgs = &__Create;\n");
  3632. output_cpp ("\t__mClass->mGetStaticField = &" ^ (
  3633. if (has_get_static_field class_def) then class_name ^ "::__GetStatic;\n" else "hx::Class_obj::GetNoStaticField;\n" ));
  3634. output_cpp ("\t__mClass->mSetStaticField = &" ^ (
  3635. if (has_set_static_field class_def) then class_name ^ "::__SetStatic;\n" else "hx::Class_obj::SetNoStaticField;\n" ));
  3636. output_cpp ("\t__mClass->mMarkFunc = sMarkStatics;\n");
  3637. output_cpp ("\t__mClass->mStatics = hx::Class_obj::dupFunctions(" ^ sStaticFields ^ ");\n");
  3638. output_cpp ("\t__mClass->mMembers = hx::Class_obj::dupFunctions(" ^ sMemberFields ^ ");\n");
  3639. output_cpp ("\t__mClass->mCanCast = hx::TCanCast< " ^ class_name ^ " >;\n");
  3640. output_cpp ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = sVisitStatics;\n#endif\n");
  3641. output_cpp ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mMemberStorageInfo = sMemberStorageInfo;\n#endif\n");
  3642. output_cpp ("#ifdef HXCPP_SCRIPTABLE\n\t__mClass->mStaticStorageInfo = sStaticStorageInfo;\n#endif\n");
  3643. output_cpp ("\thx::RegisterClass(__mClass->mName, __mClass);\n");
  3644. if (scriptable) then
  3645. output_cpp (" HX_SCRIPTABLE_REGISTER_CLASS(\""^class_name_text^"\"," ^ class_name ^ ");\n");
  3646. output_cpp ("}\n\n");
  3647. end else if not nativeGen then begin
  3648. output_cpp ("hx::Class " ^ class_name ^ "::__mClass;\n\n");
  3649. output_cpp ("void " ^ class_name ^ "::__register()\n{\n");
  3650. output_cpp ("\thx::Static(__mClass) = new hx::Class_obj();\n");
  3651. output_cpp ("\t__mClass->mName = " ^ (str class_name_text) ^ ";\n");
  3652. output_cpp ("\t__mClass->mSuper = &super::__SGetClass();\n");
  3653. output_cpp ("\t__mClass->mMarkFunc = sMarkStatics;\n");
  3654. (*output_cpp ("\t__mClass->mStatics = hx::Class_obj::dupFunctions(" ^ sStaticFields ^ ");\n");*)
  3655. output_cpp ("\t__mClass->mMembers = hx::Class_obj::dupFunctions(" ^ sMemberFields ^ ");\n");
  3656. output_cpp ("\t__mClass->mCanCast = hx::TCanCast< " ^ class_name ^ " >;\n");
  3657. output_cpp ("#ifdef HXCPP_VISIT_ALLOCS\n\t__mClass->mVisitFunc = sVisitStatics;\n#endif\n");
  3658. output_cpp ("\thx::RegisterClass(__mClass->mName, __mClass);\n");
  3659. if (scriptable) then
  3660. output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\""^class_name_text^"\"," ^ class_name ^ ");\n");
  3661. output_cpp ("}\n\n");
  3662. end;
  3663. if (has_boot_field class_def) then begin
  3664. output_cpp ("void " ^ class_name ^ "::__boot()\n{\n");
  3665. List.iter (gen_field_init ctx ) (List.filter should_implement_field class_def.cl_ordered_statics);
  3666. output_cpp ("}\n\n");
  3667. end;
  3668. gen_close_namespace output_cpp class_path;
  3669. cpp_file#close;
  3670. let h_file = new_header_file common_ctx common_ctx.file class_path in
  3671. let super = match class_def.cl_super with
  3672. | Some (klass,params) -> (class_string klass "_obj" params true)
  3673. | _ when nativeGen -> ""
  3674. | _ -> if (class_def.cl_interface) then "hx::Interface" else "hx::Object"
  3675. in
  3676. let output_h = (h_file#write) in
  3677. let def_string = join_class_path class_path "_" in
  3678. ctx.ctx_output <- output_h;
  3679. begin_header_file output_h def_string;
  3680. (* Include the real header file for the super class *)
  3681. (match class_def.cl_super with
  3682. | Some super ->
  3683. let super_path = (fst super).cl_path in
  3684. h_file#add_include super_path
  3685. | _ -> () );
  3686. (* And any interfaces ... *)
  3687. List.iter (fun imp-> h_file#add_include (fst imp).cl_path)
  3688. (real_interfaces class_def.cl_implements);
  3689. (* Only need to foreward-declare classes that are mentioned in the header file
  3690. (ie, not the implementation) *)
  3691. let referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps (Hashtbl.create 0) true false scriptable in
  3692. List.iter ( gen_forward_decl h_file ) referenced;
  3693. output_h ( get_class_code class_def Meta.HeaderCode );
  3694. let inc = get_meta_string_path class_def.cl_meta Meta.HeaderInclude in
  3695. if (inc<>"") then
  3696. output_h ("#include \"" ^ inc ^ "\"\n");
  3697. gen_open_namespace output_h class_path;
  3698. output_h "\n\n";
  3699. output_h ( get_class_code class_def Meta.HeaderNamespaceCode );
  3700. let extern_class = Common.defined common_ctx Define.DllExport in
  3701. let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES" in
  3702. if (super="") then begin
  3703. output_h ("class " ^ attribs ^ " " ^ class_name);
  3704. output_h "\n{\n\tpublic:\n";
  3705. end else begin
  3706. output_h ("class " ^ attribs ^ " " ^ class_name ^ " : public " ^ super );
  3707. output_h "\n{\n\tpublic:\n";
  3708. output_h ("\t\ttypedef " ^ super ^ " super;\n");
  3709. output_h ("\t\ttypedef " ^ class_name ^ " OBJ_;\n");
  3710. end;
  3711. if (not class_def.cl_interface && not nativeGen) then begin
  3712. output_h ("\t\t" ^ class_name ^ "();\n");
  3713. output_h ("\t\tvoid __construct(" ^ constructor_type_args ^ ");\n");
  3714. output_h "\n\tpublic:\n";
  3715. let new_arg = if (has_gc_references class_def) then "true" else "false" in
  3716. output_h ("\t\tinline void *operator new(size_t inSize, bool inContainer=" ^ new_arg
  3717. ^",const char *inName=" ^ (const_char_star class_name_text )^ ")\n" );
  3718. output_h ("\t\t\t{ return hx::Object::operator new(inSize,inContainer,inName); }\n" );
  3719. output_h ("\t\tstatic " ^ptr_name^ " __new(" ^constructor_type_args ^");\n");
  3720. output_h ("\t\tstatic Dynamic __CreateEmpty();\n");
  3721. output_h ("\t\tstatic Dynamic __Create(hx::DynamicArray inArgs);\n");
  3722. if (scriptable) then
  3723. output_h ("\t\tstatic hx::ScriptFunction __script_construct;\n");
  3724. output_h ("\t\t//~" ^ class_name ^ "();\n\n");
  3725. output_h ("\t\tHX_DO_RTTI_ALL;\n");
  3726. if (has_get_member_field class_def) then
  3727. output_h ("\t\tDynamic __Field(const ::String &inString, hx::PropertyAccess inCallProp);\n");
  3728. if (has_get_static_field class_def) then
  3729. output_h ("\t\tstatic bool __GetStatic(const ::String &inString, Dynamic &outValue, hx::PropertyAccess inCallProp);\n");
  3730. if (has_set_member_field class_def) then
  3731. output_h ("\t\tDynamic __SetField(const ::String &inString,const Dynamic &inValue, hx::PropertyAccess inCallProp);\n");
  3732. if (has_set_static_field class_def) then
  3733. output_h ("\t\tstatic bool __SetStatic(const ::String &inString, Dynamic &ioValue, hx::PropertyAccess inCallProp);\n");
  3734. if (has_get_fields class_def) then
  3735. output_h ("\t\tvoid __GetFields(Array< ::String> &outFields);\n");
  3736. if (field_integer_dynamic) then output_h "\t\tDynamic __IField(int inFieldID);\n";
  3737. if (field_integer_numeric) then output_h "\t\tdouble __INumField(int inFieldID);\n";
  3738. if (implement_dynamic) then
  3739. output_h ("\t\tHX_DECLARE_IMPLEMENT_DYNAMIC;\n");
  3740. output_h ("\t\tstatic void __register();\n");
  3741. if (override_iteration) then begin
  3742. output_h ("\t\tvoid __Mark(HX_MARK_PARAMS);\n");
  3743. output_h ("\t\tvoid __Visit(HX_VISIT_PARAMS);\n");
  3744. end;
  3745. if ( (List.length implemented) > 0 ) then begin
  3746. output_h "\t\thx::Object *__ToInterface(const hx::type_info &inType);\n";
  3747. List.iter (fun interface_name ->
  3748. output_h ("\t\toperator " ^ interface_name ^ "_obj *();\n")
  3749. ) implemented;
  3750. end;
  3751. if (has_init_field class_def) then
  3752. output_h "\t\tstatic void __init__();\n\n";
  3753. output_h ("\t\t::String __ToString() const { return " ^ (str smart_class_name) ^ "; }\n\n");
  3754. end else if not nativeGen then begin
  3755. output_h ("\t\tHX_DO_INTERFACE_RTTI;\n");
  3756. end;
  3757. if (has_boot_field class_def) then
  3758. output_h ("\t\tstatic void __boot();\n");
  3759. (match class_def.cl_array_access with
  3760. | Some t -> output_h ("\t\ttypedef " ^ (type_string t) ^ " __array_access;\n")
  3761. | _ -> ());
  3762. List.iter (gen_member_def ctx class_def true class_def.cl_interface) (List.filter should_implement_field class_def.cl_ordered_statics);
  3763. if class_def.cl_interface then begin
  3764. let dumped = ref PMap.empty in
  3765. let rec dump_def interface superToo =
  3766. List.iter (fun field -> try ignore (PMap.find field.cf_name !dumped) with Not_found ->
  3767. begin
  3768. dumped := PMap.add field.cf_name true !dumped;
  3769. gen_member_def ctx interface false true field
  3770. end
  3771. ) interface.cl_ordered_fields;
  3772. if superToo then
  3773. (match interface.cl_super with | Some super -> dump_def (fst super) true | _ -> ());
  3774. List.iter (fun impl -> dump_def (fst impl) true) (real_interfaces interface.cl_implements);
  3775. in
  3776. dump_def class_def false;
  3777. end else begin
  3778. List.iter (gen_member_def ctx class_def false false) (List.filter should_implement_field class_def.cl_ordered_fields);
  3779. end;
  3780. output_h ( get_class_code class_def Meta.HeaderClassCode );
  3781. output_h "};\n\n";
  3782. if (class_def.cl_interface && not nativeGen) then begin
  3783. output_h ("\n\n");
  3784. output_h ("template<typename IMPL>\n");
  3785. output_h ("class " ^ smart_class_name ^ "_delegate_ : public " ^ class_name^"\n");
  3786. output_h "{\n\tprotected:\n";
  3787. output_h ("\t\tIMPL *mDelegate;\n");
  3788. output_h "\tpublic:\n";
  3789. output_h ("\t\t" ^ smart_class_name ^ "_delegate_(IMPL *inDelegate) : mDelegate(inDelegate) {}\n");
  3790. output_h ("\t\thx::Object *__GetRealObject() { return mDelegate; }\n");
  3791. output_h ("\t\tvoid __Visit(HX_VISIT_PARAMS) { HX_VISIT_OBJECT(mDelegate); }\n");
  3792. let dumped = ref PMap.empty in
  3793. let rec dump_delegate interface =
  3794. List.iter (fun field -> try ignore (PMap.find field.cf_name !dumped) with Not_found ->
  3795. begin
  3796. dumped := PMap.add field.cf_name true !dumped;
  3797. match follow field.cf_type, field.cf_kind with
  3798. | _, Method MethDynamic -> ()
  3799. | TFun (args,return_type), Method _ ->
  3800. let remap_name = keyword_remap field.cf_name in
  3801. output_h ( " " ^ (type_string return_type) ^ " " ^ remap_name ^ "( " );
  3802. output_h (gen_tfun_interface_arg_list args);
  3803. output_h (") { return mDelegate->" ^ remap_name^ "(");
  3804. output_h (String.concat "," (List.map (fun (name,opt,typ) -> (keyword_remap name)) args));
  3805. output_h ");}\n";
  3806. if (reflective interface field) && not dynamic_interface_closures then
  3807. output_h (" Dynamic " ^ remap_name ^ "_dyn() { return mDelegate->" ^ remap_name ^ "_dyn();}\n");
  3808. | _ -> ()
  3809. end
  3810. ) interface.cl_ordered_fields;
  3811. (match interface.cl_super with | Some super -> dump_delegate (fst super) | _ -> ());
  3812. List.iter (fun impl -> dump_delegate (fst impl)) (real_interfaces interface.cl_implements);
  3813. in
  3814. dump_delegate class_def;
  3815. output_h "};\n\n";
  3816. end;
  3817. gen_close_namespace output_h class_path;
  3818. end_header_file output_h def_string;
  3819. h_file#close;
  3820. let depend_referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps constructor_deps false true false in
  3821. depend_referenced;;
  3822. let write_resources common_ctx =
  3823. let idx = ref 0 in
  3824. Hashtbl.iter (fun _ data ->
  3825. let id = "__res_" ^ (string_of_int !idx) in
  3826. let resource_file = new_cpp_file common_ctx common_ctx.file (["resources"],id) in
  3827. resource_file#write "namespace hx {\n";
  3828. resource_file#write_i ("unsigned char " ^ id ^ "[] = {\n");
  3829. resource_file#write_i "0xff, 0xff, 0xff, 0xff,\n";
  3830. for i = 0 to String.length data - 1 do
  3831. let code = Char.code (String.unsafe_get data i) in
  3832. resource_file#write (Printf.sprintf "%d," code);
  3833. if ( (i mod 10) = 9) then resource_file#write "\n";
  3834. done;
  3835. resource_file#write ("0x00 };\n");
  3836. incr idx;
  3837. resource_file#write ("}\n");
  3838. resource_file#close;
  3839. ) common_ctx.resources;
  3840. let resource_file = new_cpp_file common_ctx common_ctx.file ([],"__resources__") in
  3841. resource_file#write "#include <hxcpp.h>\n\n";
  3842. resource_file#write "namespace hx {\n";
  3843. idx := 0;
  3844. Hashtbl.iter (fun _ data ->
  3845. let id = "__res_" ^ (string_of_int !idx) in
  3846. resource_file#write_i ("extern unsigned char " ^ id ^ "[];\n");
  3847. incr idx;
  3848. ) common_ctx.resources;
  3849. resource_file#write "}\n\n";
  3850. idx := 0;
  3851. resource_file#write "hx::Resource __Resources[] = ";
  3852. resource_file#begin_block;
  3853. Hashtbl.iter (fun name data ->
  3854. let id = "__res_" ^ (string_of_int !idx) in
  3855. resource_file#write_i
  3856. ("{ " ^ (str name) ^ "," ^ (string_of_int (String.length data)) ^ "," ^
  3857. "hx::" ^ id ^ " + 4 },\n");
  3858. incr idx;
  3859. ) common_ctx.resources;
  3860. resource_file#write_i "{ ::String(null()),0,0 }\n";
  3861. resource_file#end_block_line;
  3862. resource_file#write ";\n\n";
  3863. resource_file#write "namespace hx { Resource *GetResources() { return __Resources; } }\n";
  3864. resource_file#close;;
  3865. let write_build_data common_ctx filename classes main_deps boot_deps build_extra extern_src exe_name =
  3866. let buildfile = open_out filename in
  3867. let include_prefix = get_include_prefix common_ctx true in
  3868. let add_class_to_buildfile class_path deps =
  3869. let cpp = (join_class_path class_path "/") ^ (source_file_extension common_ctx) in
  3870. output_string buildfile ( " <file name=\"src/" ^ cpp ^ "\">\n" );
  3871. let project_deps = List.filter (fun path -> not (is_internal_class path) ) deps in
  3872. List.iter (fun path-> output_string buildfile (" <depend name=\"" ^
  3873. ( match path with
  3874. | (["@verbatim"],file) -> file
  3875. | _ -> "include/" ^ include_prefix ^ (join_class_path path "/") ^ ".h" )
  3876. ^ "\"/>\n") ) project_deps;
  3877. output_string buildfile ( " </file>\n" )
  3878. in
  3879. let add_classdef_to_buildfile (class_path, deps, _) = add_class_to_buildfile class_path deps in
  3880. output_string buildfile "<xml>\n";
  3881. output_string buildfile ("<set name=\"HXCPP_API_LEVEL\" value=\"" ^
  3882. (Common.defined_value common_ctx Define.HxcppApiLevel) ^ "\" />\n");
  3883. output_string buildfile "<files id=\"haxe\">\n";
  3884. output_string buildfile "<compilerflag value=\"-Iinclude\"/>\n";
  3885. List.iter add_classdef_to_buildfile classes;
  3886. add_class_to_buildfile ( [] , "__boot__") boot_deps;
  3887. add_class_to_buildfile ( [] , "__files__") [];
  3888. add_class_to_buildfile ( [] , "__resources__") [];
  3889. output_string buildfile "</files>\n";
  3890. output_string buildfile "<files id=\"__lib__\">\n";
  3891. output_string buildfile "<compilerflag value=\"-Iinclude\"/>\n";
  3892. add_class_to_buildfile ( [] , "__lib__") main_deps;
  3893. output_string buildfile "</files>\n";
  3894. output_string buildfile "<files id=\"__main__\">\n";
  3895. output_string buildfile "<compilerflag value=\"-Iinclude\"/>\n";
  3896. add_class_to_buildfile ( [] , "__main__") main_deps;
  3897. output_string buildfile "</files>\n";
  3898. output_string buildfile "<files id=\"__resources__\">\n";
  3899. let idx = ref 0 in
  3900. Hashtbl.iter (fun _ data ->
  3901. let id = "__res_" ^ (string_of_int !idx) in
  3902. output_string buildfile ("<file name=\"src/resources/" ^ id ^ ".cpp\" />\n");
  3903. incr idx;
  3904. ) common_ctx.resources;
  3905. output_string buildfile "</files>\n";
  3906. output_string buildfile "<files id=\"__externs__\">\n";
  3907. List.iter (fun src -> output_string buildfile ("<file name=\"" ^src^ "\" />\n") ) extern_src;
  3908. output_string buildfile "</files>\n";
  3909. output_string buildfile ("<set name=\"HAXE_OUTPUT\" value=\"" ^ exe_name ^ "\" />\n");
  3910. output_string buildfile "<include name=\"${HXCPP}/build-tool/BuildCommon.xml\"/>\n";
  3911. output_string buildfile build_extra;
  3912. output_string buildfile "</xml>\n";
  3913. close_out buildfile;;
  3914. let write_build_options common_ctx filename defines =
  3915. let writer = cached_source_writer common_ctx filename in
  3916. PMap.iter ( fun name value -> match name with
  3917. | "true" | "sys" | "dce" | "cpp" | "debug" -> ()
  3918. | _ -> writer#write (name ^ "="^(escape_command value)^ "\n" ) ) defines;
  3919. let cmd = Unix.open_process_in "haxelib path hxcpp" in
  3920. writer#write ("hxcpp=" ^ (Pervasives.input_line cmd));
  3921. Pervasives.ignore (Unix.close_process_in cmd);
  3922. writer#close;;
  3923. let create_member_types common_ctx =
  3924. let result = Hashtbl.create 0 in
  3925. let add_member class_name interface member =
  3926. match follow member.cf_type, member.cf_kind with
  3927. | _, Var _ when interface -> ()
  3928. | _, Method MethDynamic when interface -> ()
  3929. | TFun (_,ret), _ ->
  3930. (*print_endline (class_name ^ "." ^ member.cf_name ^ "=" ^ (type_string ret) );*)
  3931. Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string ret)
  3932. | _,_ when not interface ->
  3933. Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string member.cf_type)
  3934. | _ -> ()
  3935. in
  3936. List.iter (fun object_def ->
  3937. (match object_def with
  3938. | TClassDecl class_def ->
  3939. let class_name = "::" ^ (join_class_path_remap class_def.cl_path "::") in
  3940. let rec add_all_fields class_def =
  3941. if class_def.cl_interface then
  3942. List.iter (fun impl -> add_all_fields (fst impl) ) class_def.cl_implements;
  3943. (match class_def.cl_super with Some super -> add_all_fields (fst super) | _->(););
  3944. List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_fields;
  3945. List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_statics
  3946. in
  3947. add_all_fields class_def
  3948. | _ -> ( )
  3949. ) ) common_ctx.types;
  3950. result;;
  3951. (* Builds inheritance tree, so header files can include parents defs. *)
  3952. let create_super_dependencies common_ctx =
  3953. let result = Hashtbl.create 0 in
  3954. List.iter (fun object_def ->
  3955. (match object_def with
  3956. | TClassDecl class_def when not class_def.cl_extern ->
  3957. let deps = ref [] in
  3958. (match class_def.cl_super with Some super ->
  3959. if not (fst super).cl_extern then
  3960. deps := ((fst super).cl_path) :: !deps
  3961. | _ ->() );
  3962. List.iter (fun imp -> if not (fst imp).cl_extern then deps := (fst imp).cl_path :: !deps) (real_interfaces class_def.cl_implements);
  3963. Hashtbl.add result class_def.cl_path !deps;
  3964. | TEnumDecl enum_def when not enum_def.e_extern ->
  3965. Hashtbl.add result enum_def.e_path [];
  3966. | _ -> () );
  3967. ) common_ctx.types;
  3968. result;;
  3969. let create_constructor_dependencies common_ctx =
  3970. let result = Hashtbl.create 0 in
  3971. List.iter (fun object_def ->
  3972. (match object_def with
  3973. | TClassDecl class_def when not class_def.cl_extern ->
  3974. (match class_def.cl_constructor with
  3975. | Some func_def -> Hashtbl.add result class_def.cl_path func_def
  3976. | _ -> () )
  3977. | _ -> () );
  3978. ) common_ctx.types;
  3979. result;;
  3980. (*
  3981. Exports can now be done with macros and a class list
  3982. let rec s_type t =
  3983. let result =
  3984. match t with
  3985. | TMono r -> (match !r with | None -> "Dynamic" | Some t -> s_type t)
  3986. | TEnum (e,tl) -> Ast.s_type_path e.e_path ^ s_type_params tl
  3987. | TInst (c,tl) -> Ast.s_type_path c.cl_path ^ s_type_params tl
  3988. | TType (t,tl) -> Ast.s_type_path t.t_path ^ s_type_params tl
  3989. | TAbstract (abs,pl) when abs.a_impl <> None ->
  3990. s_type (Abstract.get_underlying_type abs pl);
  3991. | TAbstract (a,tl) -> Ast.s_type_path a.a_path ^ s_type_params tl
  3992. | TFun ([],t) -> "Void -> " ^ s_fun t false
  3993. | TFun (l,t) ->
  3994. String.concat " -> " (List.map (fun (s,b,t) ->
  3995. (if b then "?" else "") ^ (""(*if s = "" then "" else s ^ " : "*)) ^ s_fun t true
  3996. ) l) ^ " -> " ^ s_fun t false
  3997. | TAnon a ->
  3998. let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name ^ " : " ^ s_type f.cf_type) :: acc) a.a_fields [] in
  3999. "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
  4000. | TDynamic t2 -> "Dynamic" ^ s_type_params (if t == t2 then [] else [t2])
  4001. | TLazy f -> s_type (!f())
  4002. in
  4003. if result="Array<haxe.io.Unsigned_char__>" then "haxe.io.BytesData" else result
  4004. and s_fun t void =
  4005. match follow t with
  4006. | TFun _ -> "(" ^ s_type t ^ ")"
  4007. | TAbstract ({ a_path = ([],"Void") },[]) when void -> "(" ^ s_type t ^ ")"
  4008. | TMono r -> (match !r with | None -> s_type t | Some t -> s_fun t void)
  4009. | TLazy f -> s_fun (!f()) void
  4010. | _ -> (s_type t)
  4011. and s_type_params = function
  4012. | [] -> ""
  4013. | l -> "< " ^ String.concat ", " (List.map s_type l) ^ " >"
  4014. ;;
  4015. let gen_extern_class common_ctx class_def file_info =
  4016. let file = new_source_file common_ctx common_ctx.file "extern" ".hx" class_def.cl_path in
  4017. let path = class_def.cl_path in
  4018. let rec remove_all_prefix class_def field t =
  4019. let path = class_def.cl_path in
  4020. let filterPath = fst path @ [snd path] in
  4021. let rec remove_prefix t = match t with
  4022. | TInst ({cl_path=[f],suffix } as cval ,tl) when f=field ->
  4023. TInst ( { cval with cl_path = ([],suffix) }, List.map remove_prefix tl)
  4024. | TInst ({cl_path=cpath,suffix } as cval ,tl) when cpath=filterPath ->
  4025. TInst ( { cval with cl_path = ([],suffix) }, List.map remove_prefix tl)
  4026. | TInst (cval,tl) -> TInst ( cval, List.map remove_prefix tl)
  4027. (*| TInst ({cl_path=prefix} as cval ,tl) ->
  4028. TInst ( { cval with cl_path = ([],snd cval.cl_path) }, List.map (remove_prefix field) tl)*)
  4029. | t -> Type.map remove_prefix t
  4030. in
  4031. let t = remove_prefix t in
  4032. let superred = (match class_def.cl_super with
  4033. | Some (super,_) -> remove_all_prefix super field t
  4034. | _ -> t )
  4035. in
  4036. List.fold_left ( fun t (impl,_) -> remove_all_prefix impl field t ) superred class_def.cl_implements;
  4037. (*
  4038. remove_prefix t
  4039. *)
  4040. in
  4041. let params = function [] -> "" | l -> "< " ^ (String.concat "," (List.map (fun (n,t) -> n) l) ^ " >") in
  4042. let output = file#write in
  4043. let print_field stat f =
  4044. let s_type t = s_type (remove_all_prefix class_def f.cf_name t) in
  4045. let args = function TFun (args,_) ->
  4046. String.concat "," (List.map (fun (name,opt,t) -> (if opt then "?" else "") ^ name ^":"^ (s_type t)) args) | _ -> "" in
  4047. let ret = function TFun (_,ret) -> s_type ret | _ -> "Dynamic" in
  4048. let override = if (is_override class_def f.cf_name ) then "override " else "" in
  4049. output ("\t" ^ (if stat then "static " else "") ^ (if f.cf_public then "public " else "") );
  4050. let s_access mode op name = match mode with
  4051. | AccNormal -> "default"
  4052. | AccNo -> "null"
  4053. | AccNever -> "never"
  4054. | AccResolve -> "resolve"
  4055. | AccCall -> op ^ "_" ^ name
  4056. | AccInline -> "default"
  4057. | AccRequire (n,_) -> "require " ^ n
  4058. in
  4059. (match f.cf_kind, f.cf_name with
  4060. | Var { v_read = AccInline; v_write = AccNever },_ ->
  4061. (match f.cf_expr with Some expr ->
  4062. output ("inline var " ^ f.cf_name ^ ":" ^ (s_type f.cf_type) ^ "=" );
  4063. let ctx = (new_extern_context common_ctx file 1 file_info) in
  4064. gen_expression ctx true expr;
  4065. | _ -> () )
  4066. | Var { v_read = AccNormal; v_write = AccNormal },_ -> output ("var " ^ f.cf_name ^ ":" ^ (s_type f.cf_type))
  4067. | Var v,_ -> output ("var " ^ f.cf_name ^ "(" ^ (s_access v.v_read "get" f.cf_name) ^ "," ^ (s_access v.v_write "set" f.cf_name) ^ "):" ^ (s_type f.cf_type))
  4068. | Method _, "new" -> output ("function new(" ^ (args f.cf_type) ^ "):Void")
  4069. | Method MethDynamic, _ -> output ("dynamic function " ^ f.cf_name ^ (params f.cf_params) ^ "(" ^ (args f.cf_type) ^ "):" ^ (ret f.cf_type) )
  4070. | Method _, _ -> output (override ^ "function " ^ f.cf_name ^ (params f.cf_params) ^ "(" ^ (args f.cf_type) ^ "):" ^ (ret f.cf_type) )
  4071. );
  4072. output ";\n\n";
  4073. in
  4074. let s_type t = s_type (remove_all_prefix class_def "*" t) in
  4075. let c = class_def in
  4076. output ( "package " ^ (String.concat "." (fst path)) ^ ";\n" );
  4077. output ( "@:include extern " ^ (if c.cl_private then "private " else "") ^ (if c.cl_interface then "interface" else "class")
  4078. ^ " " ^ (snd path) ^ (params c.cl_params) );
  4079. (match c.cl_super with None -> () | Some (c,pl) -> output (" extends " ^ (s_type (TInst (c,pl)))));
  4080. List.iter (fun (c,pl) -> output ( " implements " ^ (s_type (TInst (c,pl))))) (real_interfaces c.cl_implements);
  4081. (match c.cl_dynamic with None -> () | Some t -> output (" implements Dynamic< " ^ (s_type t) ^ " >"));
  4082. (match c.cl_array_access with None -> () | Some t -> output (" implements ArrayAccess< " ^ (s_type t) ^ " >"));
  4083. output "{\n";
  4084. (match c.cl_constructor with
  4085. | None -> ()
  4086. | Some f -> print_field false f);
  4087. let is_public f = f.cf_public in
  4088. List.iter (print_field false) (List.filter is_public c.cl_ordered_fields);
  4089. List.iter (print_field true) (List.filter is_public c.cl_ordered_statics);
  4090. output "}";
  4091. output "\n";
  4092. file#close
  4093. ;;
  4094. let gen_extern_enum common_ctx enum_def file_info =
  4095. let path = enum_def.e_path in
  4096. let file = new_source_file common_ctx common_ctx.file "extern" ".hx" path in
  4097. let output = file#write in
  4098. let params = function [] -> "" | l -> "< " ^ (String.concat "," (List.map (fun (n,t) -> n) l) ^ " >") in
  4099. output ( "package " ^ (String.concat "." (fst path)) ^ ";\n" );
  4100. output ( "@:include extern " ^ (if enum_def.e_private then "private " else "")
  4101. ^ " enum " ^ (snd path) ^ (params enum_def.e_params) );
  4102. output " {\n";
  4103. let sorted_items = List.sort (fun f1 f2 -> (f1.ef_index - f2.ef_index ) ) (pmap_values enum_def.e_constrs) in
  4104. List.iter (fun constructor ->
  4105. let name = keyword_remap constructor.ef_name in
  4106. match constructor.ef_type with
  4107. | TFun (args,_) ->
  4108. output ( name ^ "(" );
  4109. output ( String.concat "," (List.map (fun (arg,_,t) -> arg ^ ":" ^ (s_type t) ) args) );
  4110. output ");\n\n";
  4111. | _ -> output ( name ^ ";\n\n" )
  4112. ) sorted_items;
  4113. output "}\n";
  4114. file#close
  4115. ;;
  4116. *)
  4117. let is_this expression =
  4118. match (remove_parens expression).eexpr with
  4119. | TConst TThis -> true
  4120. | _ -> false
  4121. ;;
  4122. let is_super expression =
  4123. match (remove_parens expression).eexpr with
  4124. | TConst TSuper -> true
  4125. | _ -> false
  4126. ;;
  4127. let is_assign_op op =
  4128. match op with
  4129. | OpAssign
  4130. | OpAssignOp _ -> true
  4131. | _ -> false
  4132. ;;
  4133. let rec script_type_string haxe_type =
  4134. match haxe_type with
  4135. | TType ({ t_path = ([],"Null") },[t]) ->
  4136. (match follow t with
  4137. | TAbstract ({ a_path = [],"Int" },_)
  4138. | TAbstract ({ a_path = [],"Float" },_)
  4139. | TAbstract ({ a_path = [],"Bool" },_)
  4140. | TInst ({ cl_path = [],"Int" },_)
  4141. | TInst ({ cl_path = [],"Float" },_)
  4142. | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic"
  4143. | _ -> script_type_string t)
  4144. | TInst ({cl_path=[],"Null"},[t]) ->
  4145. (match follow t with
  4146. | TAbstract ({ a_path = [],"Int" },_)
  4147. | TAbstract ({ a_path = [],"Float" },_)
  4148. | TAbstract ({ a_path = [],"Bool" },_)
  4149. | TInst ({ cl_path = [],"Int" },_)
  4150. | TInst ({ cl_path = [],"Float" },_)
  4151. | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic"
  4152. | _ -> script_type_string t )
  4153. | _ ->
  4154. match follow haxe_type with
  4155. | TType ({t_path = [],"Array"},params) -> "Array"
  4156. | TInst ({cl_path=[],"Array"},params) ->
  4157. (match params with
  4158. | [t] ->
  4159. (match type_string_suff "" t false with
  4160. | "int" -> "Array.int"
  4161. | "Float" -> "Array.Float"
  4162. | "bool" -> "Array.bool"
  4163. | "::String" -> "Array.String"
  4164. | "unsigned char" -> "Array.unsigned char"
  4165. | "Dynamic" -> "Array.Any"
  4166. | _ -> "Array.Object"
  4167. )
  4168. | _ -> "Array.Object"
  4169. )
  4170. | TAbstract (abs,pl) when abs.a_impl <> None ->
  4171. script_type_string (Abstract.get_underlying_type abs pl);
  4172. | _ ->
  4173. type_string_suff "" haxe_type false
  4174. ;;
  4175. type array_of =
  4176. | ArrayInterface of int
  4177. | ArrayData of string
  4178. | ArrayObject
  4179. | ArrayAny
  4180. | ArrayNone
  4181. ;;
  4182. let is_template_type t =
  4183. false
  4184. ;;
  4185. let rec is_dynamic_in_cppia ctx expr =
  4186. match expr.eexpr with
  4187. | TCast(_,None) -> true
  4188. | _ -> is_dynamic_in_cpp ctx expr
  4189. ;;
  4190. type cppia_op =
  4191. | IaFunction
  4192. | IaVar
  4193. | IaToInterface
  4194. | IaToDynArray
  4195. | IaToDataArray
  4196. | IaToInterfaceArray
  4197. | IaFun
  4198. | IaCast
  4199. | IaBlock
  4200. | IaBreak
  4201. | IaContinue
  4202. | IaIsNull
  4203. | IaNotNull
  4204. | IaSet
  4205. | IaCall
  4206. | IaCallGlobal
  4207. | IaCallStatic
  4208. | IaCallMember
  4209. | IaCallSuper
  4210. | IaCallThis
  4211. | IaCallSuperNew
  4212. | IaCreateEnum
  4213. | IaADef
  4214. | IaIf
  4215. | IaIfElse
  4216. | IaFStatic
  4217. | IaFName
  4218. | IaFThisInst
  4219. | IaFLink
  4220. | IaFThisName
  4221. | IaFEnum
  4222. | IaThrow
  4223. | IaArrayI
  4224. | IaPlusPlus
  4225. | IaPlusPlusPost
  4226. | IaMinusMinus
  4227. | IaMinusMinusPost
  4228. | IaNeg
  4229. | IaBitNot
  4230. | IaLogicNot
  4231. | IaTVars
  4232. | IaVarDecl
  4233. | IaVarDeclI
  4234. | IaNew
  4235. | IaReturn
  4236. | IaRetVal
  4237. | IaPosInfo
  4238. | IaObjDef
  4239. | IaClassOf
  4240. | IaWhile
  4241. | IaFor
  4242. | IaEnumI
  4243. | IaSwitch
  4244. | IaTry
  4245. | IaImplDynamic
  4246. | IaConstInt
  4247. | IaConstFloat
  4248. | IaConstString
  4249. | IaConstFalse
  4250. | IaConstTrue
  4251. | IaConstNull
  4252. | IaConsThis
  4253. | IaConstSuper
  4254. | IaCastInt
  4255. | IaCastBool
  4256. | IaInterface
  4257. | IaClass
  4258. | IaAccessNormal
  4259. | IaAccessNot
  4260. | IaAccessResolve
  4261. | IaAccessCall
  4262. | IaEnum
  4263. | IaInline
  4264. | IaMain
  4265. | IaNoMain
  4266. | IaResources
  4267. | IaReso
  4268. | IaNoCast
  4269. | IaAccessCallNative
  4270. | IaBinOp of Ast.binop
  4271. ;;
  4272. let cppia_op_info = function
  4273. | IaFunction -> ("FUNCTION", 1)
  4274. | IaVar -> ("VAR", 2)
  4275. | IaToInterface -> ("TOINTERFACE", 3)
  4276. | IaToDynArray -> ("TODYNARRAY", 4)
  4277. | IaToDataArray -> ("TODATAARRAY", 5)
  4278. | IaToInterfaceArray -> ("TOINTERFACEARRAY", 6)
  4279. | IaFun -> ("FUN", 7)
  4280. | IaCast -> ("CAST", 8)
  4281. | IaBlock -> ("BLOCK", 9)
  4282. | IaBreak -> ("BREAK", 10)
  4283. | IaContinue -> ("CONTINUE", 11)
  4284. | IaIsNull -> ("ISNULL", 12)
  4285. | IaNotNull -> ("NOTNULL", 13)
  4286. | IaSet -> ("SET", 14)
  4287. | IaCall -> ("CALL", 15)
  4288. | IaCallGlobal -> ("CALLGLOBAL", 16)
  4289. | IaCallStatic -> ("CALLSTATIC", 17)
  4290. | IaCallMember -> ("CALLMEMBER", 18)
  4291. | IaCallSuper -> ("CALLSUPER", 19)
  4292. | IaCallThis -> ("CALLTHIS", 20)
  4293. | IaCallSuperNew -> ("CALLSUPERNEW", 21)
  4294. | IaCreateEnum -> ("CREATEENUM", 22)
  4295. | IaADef -> ("ADEF", 23)
  4296. | IaIf -> ("IF", 24)
  4297. | IaIfElse -> ("IFELSE", 25)
  4298. | IaFName -> ("FNAME", 27)
  4299. | IaFStatic -> ("FSTATIC", 28)
  4300. | IaFThisInst -> ("FTHISINST", 29)
  4301. | IaFLink -> ("FLINK", 30)
  4302. | IaFThisName -> ("FTHISNAME", 31)
  4303. | IaFEnum -> ("FENUM", 32)
  4304. | IaThrow -> ("THROW", 33)
  4305. | IaArrayI -> ("ARRAYI", 34)
  4306. | IaPlusPlus -> ("++", 35)
  4307. | IaPlusPlusPost -> ("+++", 36)
  4308. | IaMinusMinus -> ("--", 37)
  4309. | IaMinusMinusPost -> ("---", 38)
  4310. | IaNeg -> ("NEG", 39)
  4311. | IaBitNot -> ("~", 40)
  4312. | IaLogicNot -> ("!", 41)
  4313. | IaTVars -> ("TVARS", 42)
  4314. | IaVarDecl -> ("VARDECL", 43)
  4315. | IaVarDeclI -> ("VARDECLI", 44)
  4316. | IaNew -> ("NEW", 45)
  4317. | IaReturn -> ("RETURN", 46)
  4318. | IaRetVal -> ("RETVAL", 47)
  4319. | IaPosInfo -> ("POSINFO", 48)
  4320. | IaObjDef -> ("OBJDEF", 49)
  4321. | IaClassOf -> ("CLASSOF", 50)
  4322. | IaWhile -> ("WHILE", 51)
  4323. | IaFor -> ("FOR", 52)
  4324. | IaEnumI -> ("ENUMI", 53)
  4325. | IaSwitch -> ("SWITCH", 54)
  4326. | IaTry -> ("TRY", 55)
  4327. | IaImplDynamic -> ("IMPLDYNAMIC", 56)
  4328. | IaConstInt -> ("i", 57)
  4329. | IaConstFloat -> ("f", 58)
  4330. | IaConstString -> ("s", 59)
  4331. | IaConstFalse -> ("false", 60)
  4332. | IaConstTrue -> ("true", 61)
  4333. | IaConstNull -> ("NULL", 62)
  4334. | IaConsThis -> ("THIS", 63)
  4335. | IaConstSuper -> ("SUPER", 64)
  4336. | IaCastInt -> ("CASTINT", 65)
  4337. | IaCastBool -> ("CASTBOOL", 66)
  4338. | IaInterface -> ("INTERFACE", 67)
  4339. | IaClass -> ("CLASS", 68)
  4340. | IaAccessNormal -> ("N", 69)
  4341. | IaAccessNot -> ("n", 70)
  4342. | IaAccessResolve -> ("R", 71)
  4343. | IaAccessCall -> ("C", 72)
  4344. | IaEnum -> ("ENUM", 73)
  4345. | IaInline -> ("INLINE", 74)
  4346. | IaMain -> ("MAIN", 75)
  4347. | IaNoMain -> ("NOMAIN", 76)
  4348. | IaResources -> ("RESOURCES", 77)
  4349. | IaReso -> ("RESO", 78)
  4350. | IaNoCast -> ("NOCAST", 79)
  4351. | IaAccessCallNative -> ("V", 80)
  4352. | IaBinOp OpAdd -> ("+", 101)
  4353. | IaBinOp OpMult -> ("*", 102)
  4354. | IaBinOp OpDiv -> ("/", 103)
  4355. | IaBinOp OpSub -> ("-", 104)
  4356. | IaBinOp OpAssign -> ("=", 105)
  4357. | IaBinOp OpEq -> ("==", 106)
  4358. | IaBinOp OpNotEq -> ("!=", 107)
  4359. | IaBinOp OpGte -> (">=", 108)
  4360. | IaBinOp OpLte -> ("<=", 109)
  4361. | IaBinOp OpGt -> (">", 110)
  4362. | IaBinOp OpLt -> ("<", 111)
  4363. | IaBinOp OpAnd -> ("&", 112)
  4364. | IaBinOp OpOr -> ("|", 113)
  4365. | IaBinOp OpXor -> ("^", 114)
  4366. | IaBinOp OpBoolAnd -> ("&&", 115)
  4367. | IaBinOp OpBoolOr -> ("||", 116)
  4368. | IaBinOp OpShr -> (">>", 117)
  4369. | IaBinOp OpUShr -> (">>>", 118)
  4370. | IaBinOp OpShl -> ("<<", 119)
  4371. | IaBinOp OpMod -> ("%", 120)
  4372. | IaBinOp OpInterval -> ("...", 121)
  4373. | IaBinOp OpArrow -> ("=>", 122)
  4374. | IaBinOp OpAssignOp OpAdd -> ("+=", 201)
  4375. | IaBinOp OpAssignOp OpMult -> ("*=", 202)
  4376. | IaBinOp OpAssignOp OpDiv -> ("/=", 203)
  4377. | IaBinOp OpAssignOp OpSub -> ("-=", 204)
  4378. | IaBinOp OpAssignOp OpAnd -> ("&=", 212)
  4379. | IaBinOp OpAssignOp OpOr -> ("|=", 213)
  4380. | IaBinOp OpAssignOp OpXor -> ("^=", 214)
  4381. | IaBinOp OpAssignOp OpBoolAnd -> ("&&=", 215)
  4382. | IaBinOp OpAssignOp OpBoolOr -> ("||=", 216)
  4383. | IaBinOp OpAssignOp OpShr -> (">>=", 217)
  4384. | IaBinOp OpAssignOp OpUShr -> (">>>=", 218)
  4385. | IaBinOp OpAssignOp OpShl -> ("<<=", 219)
  4386. | IaBinOp OpAssignOp OpMod -> ("%=", 220)
  4387. | IaBinOp OpAssignOp OpInterval
  4388. | IaBinOp OpAssignOp OpAssign
  4389. | IaBinOp OpAssignOp OpEq
  4390. | IaBinOp OpAssignOp OpNotEq
  4391. | IaBinOp OpAssignOp OpGte
  4392. | IaBinOp OpAssignOp OpLte
  4393. | IaBinOp OpAssignOp OpGt
  4394. | IaBinOp OpAssignOp OpLt
  4395. | IaBinOp OpAssignOp OpAssignOp _
  4396. | IaBinOp OpAssignOp OpArrow -> assert false
  4397. ;;
  4398. class script_writer common_ctx ctx filename asciiOut =
  4399. object(this)
  4400. val debug = asciiOut
  4401. val indent_str = if asciiOut then "\t" else ""
  4402. val mutable indent = ""
  4403. val mutable indents = []
  4404. val mutable just_finished_block = false
  4405. val mutable classCount = 0
  4406. val mutable return_type = TMono(ref None)
  4407. val buffer = Buffer.create 0
  4408. val identTable = Hashtbl.create 0
  4409. val fileTable = Hashtbl.create 0
  4410. val identBuffer = Buffer.create 0
  4411. method stringId name =
  4412. try ( Hashtbl.find identTable name )
  4413. with Not_found -> begin
  4414. let size = Hashtbl.length identTable in
  4415. Hashtbl.add identTable name size;
  4416. Buffer.add_string identBuffer ((string_of_int (String.length name)) ^ " " ^ name ^ "\n");
  4417. size;
  4418. end
  4419. method incClasses = classCount <- classCount +1
  4420. method stringText name = (string_of_int (this#stringId name)) ^ " "
  4421. val typeTable = Hashtbl.create 0
  4422. val typeBuffer = Buffer.create 0
  4423. method typeId name =
  4424. let name = if name="::hx::Class" then "::Class" else name in
  4425. try ( Hashtbl.find typeTable name )
  4426. with Not_found -> begin
  4427. let size = Hashtbl.length typeTable in
  4428. Hashtbl.add typeTable name size;
  4429. Buffer.add_string typeBuffer ((string_of_int (String.length name)) ^ " " ^ name ^ "\n");
  4430. size;
  4431. end
  4432. method write str = if asciiOut then
  4433. Buffer.add_string buffer str
  4434. else begin
  4435. let push i = Buffer.add_char buffer (Char.chr i) in
  4436. let pushI32 i = push (Int32.to_int (Int32.logand i (Int32.of_int 255))) in
  4437. List.iter (fun i ->
  4438. if ((Int32.compare i Int32.zero) >= 0) && ((Int32.compare i (Int32.of_int 254)) < 0) then
  4439. pushI32 i
  4440. else if ((Int32.compare i Int32.zero) >= 0) && ((Int32.compare i (Int32.of_int 65536)) < 0) then begin
  4441. push 254;
  4442. pushI32 i;
  4443. pushI32 (Int32.shift_right i 8);
  4444. end else begin
  4445. push 255;
  4446. pushI32 i;
  4447. pushI32 (Int32.shift_right i 8);
  4448. pushI32 (Int32.shift_right i 16);
  4449. pushI32 (Int32.shift_right i 24);
  4450. end
  4451. ) (List.map Int32.of_string (Str.split (Str.regexp "[\n\t ]+") str) );
  4452. end;
  4453. just_finished_block <- false
  4454. method typeTextString typeName = (string_of_int (this#typeId typeName)) ^ " "
  4455. method typeText typeT = (string_of_int (this#typeId (script_type_string typeT))) ^ " "
  4456. method writeType typeT = this#write (this#typeText typeT)
  4457. method boolText value = if value then "1" else "0"
  4458. method writeBool value = this#write (if value then "1 " else "0 ")
  4459. method staticText value = if value then "1" else "0"
  4460. method writeData str = Buffer.add_string buffer str;
  4461. method wint ival = this#write ((string_of_int ival)^" ")
  4462. method ident name = this#wint (this#stringId name)
  4463. method instText clazz = match clazz.cl_path with
  4464. | ([],"Array") -> string_of_int (this#typeId "Array< ::Dynamic >") ^ " "
  4465. | _ -> this#typeText (TInst(clazz,[]))
  4466. method instName clazz = this#write (this#instText clazz)
  4467. method enumText e = this#typeText (TEnum(e,[]))
  4468. method enumName e = this#write (this#enumText e)
  4469. method close =
  4470. let out_file = open_out_bin filename in
  4471. output_string out_file (if asciiOut then "CPPIA\n" else "CPPIB\n");
  4472. let idents = Buffer.contents identBuffer in
  4473. output_string out_file ((string_of_int (Hashtbl.length identTable)) ^ "\n");
  4474. output_string out_file idents;
  4475. let types = Buffer.contents typeBuffer in
  4476. output_string out_file ((string_of_int (Hashtbl.length typeTable)) ^ "\n");
  4477. output_string out_file types;
  4478. output_string out_file ( (string_of_int classCount) ^ "\n" );
  4479. let contents = Buffer.contents buffer in
  4480. output_string out_file contents;
  4481. close_out out_file
  4482. method fileId file =
  4483. try ( Hashtbl.find fileTable file )
  4484. with Not_found -> begin
  4485. let stripped_file = strip_file common_ctx file in
  4486. let result = this#stringId stripped_file in
  4487. Hashtbl.add fileTable file result;
  4488. result;
  4489. end
  4490. method constText c = match c with
  4491. | TInt i -> (this#op IaConstInt) ^ (Printf.sprintf "%ld " i)
  4492. | TFloat f -> (this#op IaConstFloat) ^ (this#stringText f)
  4493. | TString s -> (this#op IaConstString) ^ (this#stringText s)
  4494. | TBool true -> (this#op IaConstTrue)
  4495. | TBool false -> (this#op IaConstFalse)
  4496. | TNull -> (this#op IaConstNull)
  4497. | TThis -> (this#op IaConsThis)
  4498. | TSuper -> (this#op IaConstSuper)
  4499. method get_array_type t =
  4500. match follow t with
  4501. | TInst ({cl_path=[],"Array"},[param]) ->
  4502. let typeName = type_string_suff "" param false in
  4503. (match typeName with
  4504. | "::String" -> ArrayData "String"
  4505. | "int" | "Float" | "bool" | "String" | "unsigned char" ->
  4506. ArrayData typeName
  4507. | "cpp::ArrayBase" | "Dynamic" -> ArrayAny
  4508. | _ when is_interface_type param -> ArrayInterface (this#typeId (script_type_string param))
  4509. | _ -> ArrayObject
  4510. )
  4511. | TAbstract (abs,pl) when abs.a_impl <> None ->
  4512. this#get_array_type (Abstract.get_underlying_type abs pl);
  4513. | _ -> ArrayNone;
  4514. method pushReturn inType =
  4515. let oldReturnType = return_type in
  4516. return_type <- inType;
  4517. fun () -> return_type <- oldReturnType;
  4518. method fileText file = string_of_int (this#fileId file)
  4519. method indent_one = this#write indent_str
  4520. method push_indent = indents <- indent_str::indents; indent <- String.concat "" indents
  4521. method pop_indent = match indents with
  4522. | h::tail -> indents <- tail; indent <- String.concat "" indents
  4523. | [] -> indent <- "/*?*/";
  4524. method write_i x = this#write (indent ^ x)
  4525. method get_indent = indent
  4526. method begin_expr = this#push_indent
  4527. method end_expr = if not just_finished_block then this#write "\n"; this#pop_indent; just_finished_block <- true
  4528. method op x = match cppia_op_info x with
  4529. | (name,index) -> (if debug then name else string_of_int index) ^ " "
  4530. method writeOp o = this#write (this#op o)
  4531. method writeOpLine o = this#write ((this#op o) ^ "\n")
  4532. method voidFunc isStatic isDynamic funcName fieldExpression =
  4533. this#write ( (this#op IaFunction) ^ (this#staticText isStatic) ^ " " ^(this#boolText isDynamic) ^ " " ^(this#stringText funcName) ^ " ");
  4534. this#write ((this#typeTextString "Void") ^ "0\n");
  4535. this#gen_expression fieldExpression
  4536. method func isStatic isDynamic funcName ret args isInterface fieldExpression =
  4537. this#write ( (this#op IaFunction) ^ (this#staticText isStatic) ^ " " ^(this#boolText isDynamic) ^ " " ^(this#stringText funcName) ^ " ");
  4538. this#write ((this#typeText ret) ^ (string_of_int (List.length args)) ^ " ");
  4539. List.iter (fun (name,opt,typ) -> this#write ( (this#stringText name) ^ (this#boolText opt) ^ " " ^ (this#typeText typ) ^ " " )) args;
  4540. this#write "\n";
  4541. if (not isInterface) then begin
  4542. match fieldExpression with
  4543. | Some ({ eexpr = TFunction function_def } as e) -> this#gen_expression e
  4544. | _ -> print_endline ("Missing function body for " ^ funcName );
  4545. end
  4546. method var readAcc writeAcc isExtern isStatic name varType varExpr =
  4547. this#write ( (this#op IaVar) ^ (this#staticText isStatic) ^ " " ^ (this#op readAcc) ^ (this#op writeAcc) ^
  4548. (this#boolText isExtern) ^ " " ^ (this#stringText name)^ (this#typeText varType) ^
  4549. (match varExpr with Some _ -> "1\n" | _ -> "0\n" ) );
  4550. match varExpr with
  4551. | Some expression -> this#gen_expression expression
  4552. | _ -> ()
  4553. method implDynamic = this#writeOpLine IaImplDynamic;
  4554. method writeVar v =
  4555. this#ident v.v_name;
  4556. this#wint v.v_id;
  4557. this#writeBool v.v_capture;
  4558. this#writeType v.v_type;
  4559. method writeList prefix len = this#write (prefix ^" " ^ (string_of_int (len)) ^ "\n");
  4560. method writePos expr = if debug then
  4561. this#write ( (this#fileText expr.epos.pfile) ^ "\t" ^ (string_of_int (Lexer.get_error_line expr.epos) ) ^ indent);
  4562. method checkCast toType expr forceCast fromGenExpression=
  4563. let write_cast text =
  4564. if (not fromGenExpression) then
  4565. this#writePos expr;
  4566. this#write (text ^"\n" );
  4567. this#begin_expr;
  4568. this#gen_expression expr;
  4569. this#end_expr;
  4570. true;
  4571. in
  4572. let was_cast =
  4573. if (is_interface_type toType) then begin
  4574. if (is_dynamic_in_cppia ctx expr) then begin
  4575. write_cast ( (this#op IaToInterface) ^ (this#typeText toType) ^ " " ^ (this#typeTextString "Dynamic") )
  4576. end else if (not (is_matching_interface_type toType expr.etype)) then begin
  4577. write_cast ( (this#op IaToInterface) ^ (this#typeText toType) ^ " " ^ (this#typeText expr.etype) )
  4578. end else
  4579. false
  4580. end else begin
  4581. let get_array_expr_type expr =
  4582. if is_dynamic_in_cppia ctx expr then
  4583. ArrayNone
  4584. else
  4585. this#get_array_type expr.etype
  4586. in
  4587. match (this#get_array_type toType), (get_array_expr_type expr) with
  4588. | ArrayAny, _ -> false
  4589. | ArrayObject, ArrayData _ -> write_cast (this#op IaToDynArray)
  4590. | ArrayData t, ArrayNone
  4591. | ArrayData t, ArrayObject
  4592. | ArrayData t, ArrayAny -> write_cast ((this#op IaToDataArray) ^ (this#typeTextString ("Array." ^ t)))
  4593. | ArrayInterface t, ArrayNone
  4594. | ArrayInterface t, ArrayAny -> write_cast ((this#op IaToInterfaceArray) ^ (string_of_int t))
  4595. | _,_ -> (* a0,a1 ->
  4596. let arrayString a =
  4597. match a with
  4598. | ArrayNone -> "ArrayNone"
  4599. | ArrayAny -> "ArrayAny"
  4600. | ArrayObject -> "ArrayObject"
  4601. | ArrayData _ -> "ArrayData"
  4602. | ArrayInterface _ -> "ArrayInterface"
  4603. in
  4604. this#write ("NOCAST " ^ (arrayString a0) ^ "=" ^ (arrayString a1)); *)
  4605. false
  4606. end
  4607. in
  4608. if (not was_cast) then begin
  4609. if (forceCast) then begin
  4610. let op =match (type_string expr.etype) with
  4611. | "int" -> IaCastInt
  4612. | "bool" -> IaCastBool
  4613. | _ when is_interface_type toType -> IaNoCast
  4614. | _ -> IaCast
  4615. in
  4616. this#writeOpLine op;
  4617. end;
  4618. this#gen_expression expr;
  4619. end
  4620. method gen_expression expr =
  4621. let expression = remove_parens expr in
  4622. this#begin_expr;
  4623. (*this#write ( (this#fileText expression.epos.pfile) ^ "\t" ^ (string_of_int (Lexer.get_error_line expression.epos) ) ^ indent);*)
  4624. this#writePos expression;
  4625. (match expression.eexpr with
  4626. | TFunction function_def -> this#write ( (this#op IaFun) ^ (this#typeText function_def.tf_type) ^ (string_of_int (List.length function_def.tf_args)) ^ "\n" );
  4627. List.iter (fun(arg,init) ->
  4628. this#write (indent ^ indent_str );
  4629. this#writeVar arg;
  4630. match init with
  4631. | Some const -> this#write ("1 " ^ (this#constText const) ^ "\n")
  4632. | _ -> this#write "0\n";
  4633. ) function_def.tf_args;
  4634. let pop = this#pushReturn function_def.tf_type in
  4635. this#gen_expression function_def.tf_expr;
  4636. pop ();
  4637. | TBlock expr_list -> this#writeList (this#op IaBlock) (List.length expr_list);
  4638. List.iter this#gen_expression expr_list;
  4639. | TConst const -> this#write (this#constText const)
  4640. | TBreak -> this#writeOp IaBreak
  4641. | TContinue -> this#writeOp IaContinue
  4642. | TBinop (op,e1,e2) when op=OpAssign ->
  4643. this#writeOpLine IaSet;
  4644. this#gen_expression e1;
  4645. this#checkCast e1.etype e2 false false;
  4646. | TBinop (OpEq ,e1, { eexpr = TConst TNull } ) -> this#writeOpLine IaIsNull;
  4647. this#gen_expression e1;
  4648. | TBinop (OpNotEq ,e1, { eexpr = TConst TNull }) -> this#writeOpLine IaNotNull;
  4649. this#gen_expression e1;
  4650. | TBinop (OpEq , { eexpr = TConst TNull }, e1) -> this#writeOpLine IaIsNull;
  4651. this#gen_expression e1;
  4652. | TBinop (OpNotEq, { eexpr = TConst TNull }, e1) -> this#writeOpLine IaNotNull;
  4653. this#gen_expression e1;
  4654. | TBinop (op,e1,e2) -> this#writeOpLine (IaBinOp op);
  4655. this#gen_expression e1;
  4656. this#gen_expression e2;
  4657. | TThrow e -> this#writeOpLine IaThrow;
  4658. this#gen_expression e;
  4659. | TArrayDecl expr_list ->
  4660. this#write ( (this#op IaADef) ^ (this#typeText expression.etype) ^ " " ^(string_of_int (List.length expr_list))^"\n");
  4661. List.iter this#gen_expression expr_list;
  4662. | TIf (e,e1,e2) ->
  4663. (match e2 with
  4664. | None ->
  4665. this#writeOpLine IaIf;
  4666. this#gen_expression e;
  4667. this#gen_expression e1;
  4668. | Some elze ->
  4669. this#writeOpLine IaIfElse;
  4670. this#gen_expression e;
  4671. this#gen_expression e1;
  4672. this#gen_expression elze; )
  4673. | TCall (func, arg_list) ->
  4674. let argN = (string_of_int (List.length arg_list)) ^ " " in
  4675. let is_real_function field =
  4676. match field.cf_kind with
  4677. | Method MethNormal | Method MethInline-> true
  4678. | _ -> false;
  4679. in
  4680. let gen_call () =
  4681. (match (remove_parens func).eexpr with
  4682. | TField ( { eexpr = TLocal { v_name = "__global__" }}, field ) ->
  4683. this#write ( (this#op IaCallGlobal) ^ (this#stringText (field_name field)) ^ argN ^ "\n");
  4684. | TField (obj,FStatic (class_def,field) ) when is_real_function field ->
  4685. this#write ( (this#op IaCallStatic) ^ (this#instText class_def) ^ " " ^ (this#stringText field.cf_name) ^
  4686. argN ^ "\n");
  4687. | TField (obj,FInstance (_,_,field) ) when (is_this obj) && (is_real_function field) ->
  4688. this#write ( (this#op IaCallThis) ^ (this#typeText obj.etype) ^ " " ^ (this#stringText field.cf_name) ^
  4689. argN ^ "\n");
  4690. | TField (obj,FInstance (_,_,field) ) when is_super obj ->
  4691. this#write ( (this#op IaCallSuper) ^ (this#typeText obj.etype) ^ " " ^ (this#stringText field.cf_name) ^
  4692. argN ^ "\n");
  4693. | TField (obj,FInstance (_,_,field) ) when is_real_function field ->
  4694. this#write ( (this#op IaCallMember) ^ (this#typeText obj.etype) ^ " " ^ (this#stringText field.cf_name) ^
  4695. argN ^ "\n");
  4696. this#gen_expression obj;
  4697. | TField (obj,FDynamic (name) ) when (is_internal_member name || (type_string obj.etype = "::String" && name="cca") ) ->
  4698. this#write ( (this#op IaCallMember) ^ (this#typeText obj.etype) ^ " " ^ (this#stringText name) ^
  4699. argN ^ "\n");
  4700. this#gen_expression obj;
  4701. | TConst TSuper -> this#write ((this#op IaCallSuperNew) ^ (this#typeText func.etype) ^ " " ^ argN ^ "\n");
  4702. | TField (_,FEnum (enum,field)) -> this#write ((this#op IaCreateEnum) ^ (this#enumText enum) ^ " " ^ (this#stringText field.ef_name) ^ argN ^ "\n");
  4703. | _ -> this#write ( (this#op IaCall) ^ argN ^ "\n");
  4704. this#gen_expression func;
  4705. );
  4706. let matched_args = match func.etype with
  4707. | TFun (args,_) ->
  4708. ( try (
  4709. List.iter2 (fun (_,_,protoT) arg -> this#checkCast protoT arg false false) args arg_list;
  4710. true; )
  4711. with Invalid_argument _ -> (*print_endline "Bad count?";*) false )
  4712. | _ -> false
  4713. in
  4714. if not matched_args then
  4715. List.iter this#gen_expression arg_list;
  4716. in
  4717. (match (remove_parens func).eexpr with
  4718. | TField(obj,field) when is_array_or_dyn_array obj.etype && (field_name field)="map" ->
  4719. (match this#get_array_type expression.etype with
  4720. | ArrayData t ->
  4721. this#write ( (this#op IaToDataArray) ^ (this#typeTextString ("Array." ^ t)) ^ "\n");
  4722. this#begin_expr;
  4723. this#writePos func;
  4724. gen_call();
  4725. this#end_expr;
  4726. | ArrayInterface t ->
  4727. this#write ( (this#op IaToInterfaceArray) ^ (string_of_int t) ^ "\n");
  4728. this#begin_expr;
  4729. this#writePos func;
  4730. gen_call();
  4731. this#end_expr;
  4732. | _ -> gen_call();
  4733. )
  4734. | _ -> gen_call();
  4735. );
  4736. | TField (obj, acc) ->
  4737. let typeText = this#typeText obj.etype in
  4738. (match acc with
  4739. | FDynamic name -> this#write ( (this#op IaFName) ^ typeText ^ " " ^ (this#stringText name) ^ "\n");
  4740. this#gen_expression obj;
  4741. | FStatic (class_def,field) -> this#write ( (this#op IaFStatic) ^ (this#instText class_def) ^ " " ^ (this#stringText field.cf_name) );
  4742. | FInstance (_,_,field) when is_this obj -> this#write ( (this#op IaFThisInst) ^ typeText ^ " " ^ (this#stringText field.cf_name) );
  4743. | FInstance (_,_,field) -> this#write ( (this#op IaFLink) ^ typeText ^ " " ^ (this#stringText field.cf_name) ^ "\n");
  4744. this#gen_expression obj;
  4745. | FClosure (_,field) when is_this obj -> this#write ( (this#op IaFThisName) ^typeText ^ " " ^ (this#stringText field.cf_name) ^ "\n")
  4746. | FAnon (field) when is_this obj -> this#write ( (this#op IaFThisName) ^typeText ^ " " ^ (this#stringText field.cf_name) ^ "\n")
  4747. | FClosure (_,field)
  4748. | FAnon (field) -> this#write ( (this#op IaFName) ^typeText ^ " " ^ (this#stringText field.cf_name) ^ "\n");
  4749. this#gen_expression obj;
  4750. | FEnum (enum,field) -> this#write ( (this#op IaFEnum) ^ (this#enumText enum) ^ " " ^ (this#stringText field.ef_name) );
  4751. )
  4752. | TArray (e1, e2) -> this#write ((this#op IaArrayI) ^ (this#typeText e1.etype) ^ "\n");
  4753. this#gen_expression e1;
  4754. this#gen_expression e2;
  4755. | TUnop (op, flag, e) ->
  4756. this#writeOpLine (match op,flag with
  4757. | Increment, Prefix -> IaPlusPlus
  4758. | Increment, _ -> IaPlusPlusPost
  4759. | Decrement, Prefix -> IaMinusMinus
  4760. | Decrement, _ -> IaMinusMinusPost
  4761. | Not, _ -> IaLogicNot
  4762. | Neg, _ -> IaNeg
  4763. | NegBits, _ -> IaBitNot );
  4764. this#gen_expression e;
  4765. (* TODO - lval op-assign local/member/array *)
  4766. | TLocal var -> this#write ((this#op IaVar) ^ (string_of_int var.v_id) );
  4767. | TVar (tvar,optional_init) ->
  4768. this#write ( (this#op IaTVars) ^ (string_of_int (1)) ^ "\n");
  4769. this#write ("\t\t" ^ indent);
  4770. (match optional_init with
  4771. | None -> this#writeOp IaVarDecl;
  4772. this#writeVar tvar;
  4773. | Some init ->this#writeOp IaVarDeclI;
  4774. let init = remove_parens init in
  4775. this#writeVar tvar;
  4776. this#write (" " ^ (this#typeText init.etype));
  4777. this#write "\n";
  4778. this#checkCast tvar.v_type init false false);
  4779. | TNew (clazz,params,arg_list) ->
  4780. this#write ((this#op IaNew) ^ (this#typeText (TInst(clazz,params))) ^ (string_of_int (List.length arg_list)) ^ "\n");
  4781. let rec matched_args clazz = match clazz.cl_constructor, clazz.cl_super with
  4782. | None, Some super -> matched_args (fst super)
  4783. | None, _ -> false
  4784. | Some ctr, _ ->
  4785. (match ctr.cf_type with
  4786. | TFun(args,_) ->
  4787. ( try (
  4788. List.iter2 (fun (_,_,protoT) arg -> this#checkCast protoT arg false false) args arg_list;
  4789. true; )
  4790. with Invalid_argument _ -> (*print_endline "Bad count?";*) false )
  4791. | _ -> false
  4792. )
  4793. in
  4794. if not (matched_args clazz) then
  4795. List.iter this#gen_expression arg_list;
  4796. | TReturn optval -> (match optval with
  4797. | None -> this#writeOpLine IaReturn;
  4798. | Some value -> this#write ( (this#op IaRetVal) ^ (this#typeText value.etype) ^ "\n");
  4799. this#checkCast return_type value false false;
  4800. )
  4801. | TObjectDecl (
  4802. ("fileName" , { eexpr = (TConst (TString file)) }) ::
  4803. ("lineNumber" , { eexpr = (TConst (TInt line)) }) ::
  4804. ("className" , { eexpr = (TConst (TString class_name)) }) ::
  4805. ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) ->
  4806. this#write ( (this#op IaPosInfo) ^ (this#stringText file) ^ (Printf.sprintf "%ld" line) ^ " " ^
  4807. (this#stringText class_name) ^ " " ^ (this#stringText meth))
  4808. | TObjectDecl values ->this#write ( (this#op IaObjDef) ^ (string_of_int (List.length values)));
  4809. this#write " ";
  4810. List.iter (fun (name,_) -> this#write (this#stringText name) ) values;
  4811. this#write "\n";
  4812. List.iter (fun (_,e) -> this#gen_expression e ) values;
  4813. | TTypeExpr type_expr ->
  4814. let klass = "::" ^ (join_class_path (t_path type_expr) "::" ) in
  4815. this#write ((this#op IaClassOf) ^ (string_of_int (this#typeId klass)))
  4816. | TWhile (e1,e2,flag) -> this#write ( (this#op IaWhile) ^ (if flag=NormalWhile then "1" else "0" ) ^ "\n");
  4817. this#gen_expression e1;
  4818. this#gen_expression e2;
  4819. | TFor (tvar,init,loop) -> this#writeOp IaFor;
  4820. this#writeVar tvar;
  4821. this#write "\n";
  4822. this#gen_expression init;
  4823. this#gen_expression loop;
  4824. | TEnumParameter (expr,ef,i) ->
  4825. let enum = match follow ef.ef_type with
  4826. | TEnum(en,_) | TFun(_,TEnum(en,_)) -> en
  4827. | _ -> assert false
  4828. in
  4829. this#write ( (this#op IaEnumI) ^ (this#typeText (TEnum(enum,[])) ) ^ (string_of_int i) ^ "\n");
  4830. this#gen_expression expr;
  4831. | TSwitch (condition,cases,optional_default) ->
  4832. this#write ( (this#op IaSwitch) ^ (string_of_int (List.length cases)) ^ " " ^
  4833. (match optional_default with None -> "0" | Some _ -> "1") ^ "\n");
  4834. this#gen_expression condition;
  4835. List.iter (fun (cases_list,expression) ->
  4836. this#writeList ("\t\t\t"^indent) (List.length cases_list);
  4837. List.iter (fun value -> this#gen_expression value ) cases_list;
  4838. this#gen_expression expression;
  4839. ) cases;
  4840. (match optional_default with None -> () | Some expr -> this#gen_expression expr);
  4841. | TTry (e,catches) ->
  4842. this#writeList (this#op IaTry) (List.length catches);
  4843. this#gen_expression e;
  4844. List.iter ( fun (tvar,catch_expr) ->
  4845. this#write ("\t\t\t"^indent);
  4846. this#writeVar tvar;
  4847. this#write "\n";
  4848. this#gen_expression catch_expr;
  4849. ) catches;
  4850. | TCast (cast,None) -> this#checkCast expression.etype cast true true;
  4851. | TCast (cast,Some _) -> this#checkCast expression.etype cast true true;
  4852. | TParenthesis _ -> error "Unexpected parens" expression.epos
  4853. | TMeta(_,_) -> error "Unexpected meta" expression.epos
  4854. );
  4855. this#end_expr;
  4856. end;;
  4857. let generate_script_class common_ctx script class_def =
  4858. script#incClasses;
  4859. script#writeOp (if class_def.cl_interface then IaInterface else IaClass );
  4860. script#instName class_def;
  4861. (match class_def.cl_super with
  4862. | None -> script#ident ""
  4863. | Some (c,_) -> script#instName c);
  4864. script#wint (List.length class_def.cl_implements);
  4865. List.iter (fun(c,_) -> script#instName c) class_def.cl_implements;
  4866. script#write "\n";
  4867. (* Looks like some map impl classes have their bodies discarded - not sure best way to filter *)
  4868. let non_dodgy_function field =
  4869. class_def.cl_interface ||
  4870. match field.cf_kind, field.cf_expr with
  4871. | Var _, _ -> true
  4872. | Method MethDynamic, _ -> true
  4873. | Method _, Some _ -> true
  4874. | _ -> false
  4875. in
  4876. let ordered_statics = List.filter non_dodgy_function class_def.cl_ordered_statics in
  4877. let ordered_fields = List.filter non_dodgy_function class_def.cl_ordered_fields in
  4878. script#write ((string_of_int ( (List.length ordered_fields) +
  4879. (List.length ordered_statics) +
  4880. (match class_def.cl_constructor with Some _ -> 1 | _ -> 0 ) +
  4881. (if (implement_dynamic_here class_def) then 1 else 0) +
  4882. (match class_def.cl_init with Some _ -> 1 | _ -> 0 ) ) )
  4883. ^ "\n");
  4884. let generate_field isStatic field =
  4885. match field.cf_kind, follow field.cf_type with
  4886. | Var { v_read = AccInline; v_write = AccNever },_ ->
  4887. script#writeOpLine IaInline;
  4888. | Var v,_ ->
  4889. let mode_code mode = match mode with
  4890. | AccNormal -> IaAccessNormal
  4891. | AccNo -> IaAccessNot
  4892. | AccNever -> IaAccessNot
  4893. | AccResolve -> IaAccessResolve
  4894. | AccCall -> if ( (has_meta_key class_def.cl_meta Meta.NativeProperty) ||
  4895. (has_meta_key field.cf_meta Meta.NativeProperty) ||
  4896. (Common.defined common_ctx Define.ForceNativeProperty) )
  4897. then IaAccessCallNative else IaAccessCall;
  4898. | AccInline -> IaAccessNormal
  4899. | AccRequire (_,_) -> IaAccessNormal
  4900. in
  4901. let isExtern = is_extern_field field in
  4902. script#var (mode_code v.v_read) (mode_code v.v_write) isExtern isStatic field.cf_name field.cf_type field.cf_expr
  4903. | Method MethDynamic, TFun(args,ret) ->
  4904. script#func isStatic true field.cf_name ret args class_def.cl_interface field.cf_expr
  4905. | Method _, TFun(args,ret) when field.cf_name="new" ->
  4906. script#func true false "new" (TInst(class_def,[])) args false field.cf_expr
  4907. | Method _, TFun (args,ret) ->
  4908. script#func isStatic false field.cf_name ret args class_def.cl_interface field.cf_expr
  4909. | Method _, _ -> print_endline ("Unknown method type " ^ (join_class_path class_def.cl_path "." )
  4910. ^ "." ^field.cf_name )
  4911. in
  4912. (match class_def.cl_constructor with
  4913. | Some field -> generate_field true field
  4914. | _ -> () );
  4915. (match class_def.cl_init with
  4916. | Some expression -> script#voidFunc true false "__init__" expression
  4917. | _ -> () );
  4918. List.iter (generate_field false) ordered_fields;
  4919. List.iter (generate_field true) ordered_statics;
  4920. if (implement_dynamic_here class_def) then
  4921. script#implDynamic;
  4922. script#write "\n";
  4923. ;;
  4924. let generate_script_enum common_ctx script enum_def meta =
  4925. script#incClasses;
  4926. let sorted_items = List.sort (fun f1 f2 -> (f1.ef_index - f2.ef_index ) ) (pmap_values enum_def.e_constrs) in
  4927. script#writeList ((script#op IaEnum) ^ (script#enumText enum_def)) (List.length sorted_items);
  4928. List.iter (fun constructor ->
  4929. let name = script#stringText constructor.ef_name in
  4930. match constructor.ef_type with
  4931. | TFun (args,_) ->
  4932. script#write ( name ^ " " ^ (string_of_int (List.length args)) );
  4933. List.iter (fun (arg,_,t) -> script#write ( " " ^ (script#stringText arg) ^ " " ^ (script#typeText t) ) ) args;
  4934. script#write "\n";
  4935. | _ -> script#write ( name ^ " 0\n" )
  4936. ) sorted_items;
  4937. match meta with
  4938. | Some expr -> script#write "1\n";
  4939. script#gen_expression expr
  4940. | _ -> script#write "0\n";
  4941. script#write "\n"
  4942. ;;
  4943. let generate_cppia common_ctx =
  4944. let debug = 1 in
  4945. let null_file = new source_writer common_ctx ignore (fun () -> () ) in
  4946. let ctx = new_context common_ctx null_file debug (ref PMap.empty) in
  4947. ctx.ctx_class_member_types <- create_member_types common_ctx;
  4948. let script = new script_writer common_ctx ctx common_ctx.file common_ctx.debug in
  4949. ignore (script#stringId "");
  4950. ignore (script#typeId "");
  4951. List.iter (fun object_def ->
  4952. (match object_def with
  4953. | TClassDecl class_def when class_def.cl_extern ->
  4954. () (*if (gen_externs) then gen_extern_class common_ctx class_def;*)
  4955. | TClassDecl class_def ->
  4956. let is_internal = is_internal_class class_def.cl_path in
  4957. if (is_internal || (is_macro class_def.cl_meta)) then
  4958. ( if (debug>1) then print_endline (" internal class " ^ (join_class_path class_def.cl_path ".") ))
  4959. else begin
  4960. ctx.ctx_class_name <- "::" ^ (join_class_path class_def.cl_path "::");
  4961. generate_script_class common_ctx script class_def
  4962. end
  4963. | TEnumDecl enum_def when enum_def.e_extern -> ()
  4964. | TEnumDecl enum_def ->
  4965. let is_internal = is_internal_class enum_def.e_path in
  4966. if (is_internal) then
  4967. (if (debug>1) then print_endline (" internal enum " ^ (join_class_path enum_def.e_path ".") ))
  4968. else begin
  4969. let meta = Codegen.build_metadata common_ctx object_def in
  4970. if (enum_def.e_extern) then
  4971. (if (debug>1) then print_endline ("external enum " ^ (join_class_path enum_def.e_path ".") ));
  4972. ctx.ctx_class_name <- "*";
  4973. generate_script_enum common_ctx script enum_def meta
  4974. end
  4975. | TTypeDecl _ | TAbstractDecl _ -> (* already done *) ()
  4976. );
  4977. ) common_ctx.types;
  4978. (match common_ctx.main with
  4979. | None -> script#writeOpLine IaNoMain;
  4980. | Some e -> script#writeOpLine IaMain;
  4981. script#gen_expression e
  4982. );
  4983. script#write ( (script#op IaResources) ^ (string_of_int (Hashtbl.length common_ctx.resources)) ^ "\n");
  4984. Hashtbl.iter (fun name data ->
  4985. script#write ((script#op IaReso) ^ (script#stringText name) ^ (string_of_int (String.length data)) ^ "\n");
  4986. ) common_ctx.resources;
  4987. Hashtbl.iter (fun _ data -> script#writeData data) common_ctx.resources;
  4988. script#close
  4989. ;;
  4990. (*
  4991. The common_ctx contains the haxe AST in the "types" field and the resources
  4992. *)
  4993. let generate_source common_ctx =
  4994. make_base_directory common_ctx.file;
  4995. let debug = 1 in
  4996. let exe_classes = ref [] in
  4997. let boot_classes = ref [] in
  4998. let boot_enums = ref [] in
  4999. let nonboot_classes = ref [] in
  5000. let init_classes = ref [] in
  5001. let file_info = ref PMap.empty in
  5002. let class_text path = join_class_path path "::" in
  5003. let member_types = create_member_types common_ctx in
  5004. let super_deps = create_super_dependencies common_ctx in
  5005. let constructor_deps = create_constructor_dependencies common_ctx in
  5006. let main_deps = ref [] in
  5007. let extern_src = ref [] in
  5008. let build_xml = ref "" in
  5009. let scriptable = (Common.defined common_ctx Define.Scriptable) in
  5010. List.iter (fun object_def ->
  5011. (* check if any @:objc class is referenced while '-D objc' is not defined
  5012. This will guard all code changes to this flag *)
  5013. (if not (Common.defined common_ctx Define.Objc) then match object_def with
  5014. | TClassDecl class_def when Meta.has Meta.Objc class_def.cl_meta ->
  5015. error "In order to compile '@:objc' classes, please define '-D objc'" class_def.cl_pos
  5016. | _ -> ());
  5017. (match object_def with
  5018. | TClassDecl class_def when is_extern_class class_def ->
  5019. build_xml := !build_xml ^ (get_class_code class_def Meta.BuildXml);
  5020. let source = get_meta_string_path class_def.cl_meta Meta.SourceFile in
  5021. if (source<>"") then
  5022. extern_src := source :: !extern_src;
  5023. | TClassDecl class_def ->
  5024. let name = class_text class_def.cl_path in
  5025. let is_internal = is_internal_class class_def.cl_path in
  5026. if (is_internal || (is_macro class_def.cl_meta)) then
  5027. ( if (debug>1) then print_endline (" internal class " ^ name ))
  5028. else begin
  5029. build_xml := !build_xml ^ (get_class_code class_def Meta.BuildXml);
  5030. if (has_init_field class_def) then
  5031. init_classes := class_def.cl_path :: !init_classes;
  5032. if (has_boot_field class_def) then
  5033. boot_classes := class_def.cl_path :: !boot_classes
  5034. else if not (has_meta_key class_def.cl_meta Meta.NativeGen) then
  5035. nonboot_classes := class_def.cl_path :: !nonboot_classes;
  5036. let deps = generate_class_files common_ctx
  5037. member_types super_deps constructor_deps class_def file_info scriptable in
  5038. exe_classes := (class_def.cl_path, deps, object_def) :: !exe_classes;
  5039. end
  5040. | TEnumDecl enum_def when enum_def.e_extern -> ()
  5041. | TEnumDecl enum_def ->
  5042. let name = class_text enum_def.e_path in
  5043. let is_internal = is_internal_class enum_def.e_path in
  5044. if (is_internal) then
  5045. (if (debug>1) then print_endline (" internal enum " ^ name ))
  5046. else begin
  5047. let meta = Codegen.build_metadata common_ctx object_def in
  5048. if (enum_def.e_extern) then
  5049. (if (debug>1) then print_endline ("external enum " ^ name ));
  5050. boot_enums := enum_def.e_path :: !boot_enums;
  5051. let deps = generate_enum_files common_ctx enum_def super_deps meta file_info in
  5052. exe_classes := (enum_def.e_path, deps, object_def) :: !exe_classes;
  5053. end
  5054. | TTypeDecl _ | TAbstractDecl _ -> (* already done *) ()
  5055. );
  5056. ) common_ctx.types;
  5057. (match common_ctx.main with
  5058. | None -> generate_dummy_main common_ctx
  5059. | Some e ->
  5060. let main_field = { cf_name = "__main__"; cf_type = t_dynamic; cf_expr = Some e; cf_pos = e.epos; cf_public = true; cf_meta = []; cf_overloads = []; cf_doc = None; cf_kind = Var { v_read = AccNormal; v_write = AccNormal; }; cf_params = [] } in
  5061. let class_def = { null_class with cl_path = ([],"@Main"); cl_ordered_statics = [main_field] } in
  5062. main_deps := find_referenced_types common_ctx (TClassDecl class_def) super_deps constructor_deps false true false;
  5063. generate_main common_ctx member_types super_deps class_def file_info
  5064. );
  5065. generate_boot common_ctx !boot_enums !boot_classes !nonboot_classes !init_classes;
  5066. generate_files common_ctx file_info;
  5067. write_resources common_ctx;
  5068. (* Output class info if requested *)
  5069. if (scriptable || (Common.defined common_ctx Define.DllExport) ) then begin
  5070. let filename =
  5071. try
  5072. let value = Common.defined_value common_ctx Define.DllExport in
  5073. if value="1" then raise Not_found;
  5074. value
  5075. with Not_found -> "export_classes.info"
  5076. in
  5077. if (filename <> "") then begin
  5078. let escape s =
  5079. let b = Buffer.create 0 in
  5080. for i = 0 to String.length s - 1 do
  5081. let c = String.unsafe_get s i in
  5082. match c with
  5083. | '\\' -> Buffer.add_char b c; Buffer.add_char b c;
  5084. | ' ' -> Buffer.add_char b '\\'; Buffer.add_char b 's';
  5085. | '\n' -> Buffer.add_char b '\\'; Buffer.add_char b 'n';
  5086. | _ -> Buffer.add_char b c;
  5087. done;
  5088. Buffer.contents b;
  5089. in
  5090. let exeClasses = open_out filename in
  5091. let out = output_string exeClasses in
  5092. let outline str = output_string exeClasses (str ^ "\n") in
  5093. let spath path = (join_class_path path ".") in
  5094. let rec stype = function
  5095. | TMono r -> (match !r with None -> "Dynamic" | Some t -> stype t)
  5096. | TAbstract ({ a_path = ([],"Void") },[]) -> "void"
  5097. | TAbstract ({ a_path = ([],"Bool") },[]) -> "bool"
  5098. | TAbstract ({ a_path = ([],"Float") },[]) -> "float"
  5099. | TAbstract ({ a_path = ([],"Int") },[]) -> "int"
  5100. | TAbstract( { a_path = ([], "EnumValue") }, _ ) -> "Dynamic"
  5101. | TEnum (enum,params) -> spath enum.e_path
  5102. | TInst (klass,params) ->
  5103. (match klass.cl_path, params with
  5104. (* Array class *)
  5105. (*| ([],"Array") when is_dynamic_array_param (List.hd params) -> "Dynamic" *)
  5106. | _,_ when is_dynamic_type_param klass.cl_kind -> "Dynamic"
  5107. | ([],"Array"), [t] -> "Array<" ^ (stype t) ^ ">"
  5108. | (["haxe";"io"],"Unsigned_char__"),_ -> "uint8"
  5109. | ([],"EnumValue"),_ -> "Dynamic"
  5110. | ([],"Null"),[t] when cant_be_null t -> "Null<" ^ (stype t) ^ ">"
  5111. | ([],"Null"),[t] -> (stype t)
  5112. | _ -> spath klass.cl_path
  5113. )
  5114. | TType (type_def,params) ->
  5115. (match type_def.t_path, params with
  5116. | ([],"Null"),[t] when cant_be_null t -> "Null<" ^ (stype t) ^ ">"
  5117. | ([],"Array"), [t] -> "Array< " ^ (stype (follow t) ) ^ " >"
  5118. | _,_ -> stype (apply_params type_def.t_params params type_def.t_type)
  5119. )
  5120. | TLazy func -> stype ((!func)())
  5121. | TAbstract (abs,pl) when abs.a_impl <> None ->
  5122. stype (Abstract.get_underlying_type abs pl)
  5123. | TAbstract (abs,_) -> spath abs.a_path
  5124. | TFun (args,ret) -> "fun<" ^ (List.fold_left (fun s (_,opt,t) -> s ^ (if opt then "?" else "") ^ (stype t) ^ ",") "" args) ^ (stype ret) ^ ">"
  5125. | _ -> "Dynamic"
  5126. in
  5127. List.iter (fun (name,_,def) ->
  5128. match def with
  5129. | TClassDecl class_def ->
  5130. outline ((if class_def.cl_interface then "interface " else "class ") ^ (spath name) );
  5131. (match class_def.cl_super with
  5132. | Some (super,_) -> outline ("super " ^ (spath super.cl_path) )
  5133. | _ -> () );
  5134. List.iter ( fun(c,_) -> out ("implements " ^ (spath c.cl_path) ^ "\n") ) class_def.cl_implements;
  5135. (match class_def.cl_dynamic with None -> () | Some t -> outline ("implementsdynamic " ^ (stype t)));
  5136. (match class_def.cl_array_access with None -> () | Some t -> outline ("arrayaccess " ^ (stype t)));
  5137. let args = function
  5138. | TFun (args,_) ->
  5139. List.iter (fun (name,opt,t) ->
  5140. outline ("arg " ^ name ^ (if opt then " ? " else " : ") ^ (stype t) )
  5141. ) args;
  5142. | _ -> () in
  5143. let ret = function TFun (_,ret) -> stype ret | _ -> "Dynamic" in
  5144. let print_field stat f =
  5145. let pub = if f.cf_public then "pub " else "priv " in
  5146. let stat = pub ^ ( if stat then "s " else "m " ) in
  5147. (match f.cf_kind, f.cf_name with
  5148. | Var { v_read = AccInline; v_write = AccNever },_ ->
  5149. outline ("inlinevar " ^ f.cf_name ^ " " ^ (stype f.cf_type) )
  5150. | Var { v_read = AccNormal; v_write = AccNormal },_ ->
  5151. outline ("var " ^ stat ^ f.cf_name ^ " " ^ (stype f.cf_type) )
  5152. | Var v,_ ->
  5153. let saccess = function | AccNormal -> "v" | AccNo -> "0" | AccNever -> "!"
  5154. | AccResolve -> "r" | AccCall -> "c" | AccInline -> "i" | AccRequire (_,_) -> "v" in
  5155. outline ("property " ^ stat ^ (saccess v.v_read) ^ " " ^ (saccess v.v_write)
  5156. ^ " " ^ f.cf_name ^ " " ^ (stype f.cf_type) )
  5157. | Method _, "new" ->
  5158. outline ("function " ^ stat ^ "new " ^ (ret f.cf_type) );
  5159. args f.cf_type
  5160. | Method MethDynamic, _ ->
  5161. outline ("dynamicfunction " ^ stat ^ f.cf_name ^ " " ^ (ret f.cf_type) );
  5162. args f.cf_type
  5163. | Method _, _ ->
  5164. outline ("function " ^ stat ^ f.cf_name ^ " " ^ (ret f.cf_type) );
  5165. args f.cf_type
  5166. ) in
  5167. (match class_def.cl_constructor with | None -> () | Some f -> print_field false f);
  5168. List.iter (print_field false) class_def.cl_ordered_fields;
  5169. List.iter (print_field true) class_def.cl_ordered_statics;
  5170. | TEnumDecl enum_def ->
  5171. out ("enum " ^ (spath name) ^ "\n");
  5172. let sorted_items = List.sort (fun f1 f2 -> (f1.ef_index - f2.ef_index ) ) (pmap_values enum_def.e_constrs) in
  5173. List.iter (fun constructor ->
  5174. outline ("constructor " ^ constructor.ef_name);
  5175. match constructor.ef_type with
  5176. | TFun (args,_) -> List.iter (fun (arg,_,t) -> outline ("eparam " ^ arg ^ " " ^ (stype t) ) ) args;
  5177. | _ -> ()
  5178. ) sorted_items;
  5179. | _ -> ()
  5180. ) !exe_classes;
  5181. (* Output file info too *)
  5182. List.iter ( fun file ->
  5183. let full_path = Common.get_full_path (try Common.find_file common_ctx file with Not_found -> file) in
  5184. out ("file " ^ (escape file) ^ " " ^ (escape full_path) ^"\n") )
  5185. ( List.sort String.compare ( pmap_keys !file_info) );
  5186. close_out exeClasses;
  5187. end;
  5188. end;
  5189. let output_name = match common_ctx.main_class with
  5190. | Some path -> (snd path)
  5191. | _ -> "output" in
  5192. write_build_data common_ctx (common_ctx.file ^ "/Build.xml") !exe_classes !main_deps (!boot_enums@ !boot_classes) !build_xml !extern_src output_name;
  5193. let cmd_defines = ref "" in
  5194. PMap.iter ( fun name value -> match name with
  5195. | "true" | "sys" | "dce" | "cpp" | "debug" -> ()
  5196. | _ -> cmd_defines := !cmd_defines ^ " -D" ^ name ^ "=\"" ^ (escape_command value) ^ "\"" ) common_ctx.defines;
  5197. write_build_options common_ctx (common_ctx.file ^ "/Options.txt") common_ctx.defines;
  5198. if ( not (Common.defined common_ctx Define.NoCompilation) ) then begin
  5199. let t = Common.timer "generate cpp - native compilation" in
  5200. let old_dir = Sys.getcwd() in
  5201. Sys.chdir common_ctx.file;
  5202. let cmd = ref "haxelib run hxcpp Build.xml haxe" in
  5203. if (common_ctx.debug) then cmd := !cmd ^ " -Ddebug";
  5204. cmd := !cmd ^ !cmd_defines;
  5205. cmd := List.fold_left (fun cmd path -> cmd ^ " -I\"" ^ (escape_command path) ^ "\"" ) !cmd common_ctx.class_path;
  5206. print_endline !cmd;
  5207. if common_ctx.run_command !cmd <> 0 then failwith "Build failed";
  5208. Sys.chdir old_dir;
  5209. t()
  5210. end
  5211. ;;
  5212. let generate common_ctx =
  5213. if (Common.defined common_ctx Define.Cppia) then
  5214. generate_cppia common_ctx
  5215. else
  5216. generate_source common_ctx
  5217. ;;