gencpp.ml 187 KB

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