gencpp.ml 219 KB

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