gencpp.ml 233 KB

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