gencommon.ml 412 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386
  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. (*
  17. Gen Common API
  18. This module intends to be a common set of utilities common to all targets.
  19. It's intended to provide a set of tools to be able to make targets in Haxe more easily, and to
  20. allow the programmer to have more control of how the target language will handle the program.
  21. For example, as of now, the hxcpp target, while greatly done, relies heavily on cpp's own operator
  22. overloading, and implicit conversions, which make it very hard to deliver a similar solution for languages
  23. that lack these features.
  24. So this little framework is here so you can manipulate the Haxe AST and start bringing the AST closer
  25. to how it's intenteded to be in your host language.
  26. Rules
  27. Design goals
  28. Naming convention
  29. Weaknesses and TODO's
  30. *)
  31. open Unix
  32. open Ast
  33. open Type
  34. open Common
  35. open Option
  36. open Printf
  37. open ExtString
  38. let debug_type_ctor = function
  39. | TMono _ -> "TMono"
  40. | TEnum _ -> "TEnum"
  41. | TInst _ -> "TInst"
  42. | TType _ -> "TType"
  43. | TFun _ -> "TFun"
  44. | TAnon _ -> "TAnon"
  45. | TDynamic _ -> "TDynamic"
  46. | TLazy _ -> "TLazy"
  47. | TAbstract _ -> "TAbstract"
  48. let debug_type = (s_type (print_context()))
  49. let debug_expr = s_expr debug_type
  50. let rec like_float t =
  51. match follow t with
  52. | TAbstract({ a_path = ([], "Float") },[])
  53. | TAbstract({ a_path = ([], "Int") },[]) -> true
  54. | TAbstract({ a_path = (["cs"], "Pointer") },_) -> false
  55. | TAbstract(a, _) -> List.exists (fun t -> like_float t) a.a_from || List.exists (fun t -> like_float t) a.a_to
  56. | _ -> false
  57. let rec like_int t =
  58. match follow t with
  59. | TAbstract({ a_path = ([], "Int") },[]) -> true
  60. | TAbstract({ a_path = (["cs"], "Pointer") },_) -> false
  61. | TAbstract(a, _) -> List.exists (fun t -> like_int t) a.a_from || List.exists (fun t -> like_int t) a.a_to
  62. | _ -> false
  63. let rec like_i64 t =
  64. match follow t with
  65. | TInst({ cl_path = (["cs"], "Int64") },[])
  66. | TAbstract({ a_path = (["cs"], "Int64") },[])
  67. | TInst({ cl_path = (["cs"], "UInt64") },[])
  68. | TInst({ cl_path = (["java"], "Int64") },[])
  69. | TAbstract({ a_path = (["java"], "Int64") },[])
  70. | TInst({ cl_path = (["haxe"], "Int64") },[])
  71. | TAbstract({ a_path = (["haxe"], "Int64") },[]) -> true
  72. | TAbstract(a, _) -> List.exists (fun t -> like_i64 t) a.a_from || List.exists (fun t -> like_i64 t) a.a_to
  73. | _ -> false
  74. let follow_once t =
  75. match t with
  76. | TMono r ->
  77. (match !r with
  78. | Some t -> t
  79. | _ -> t_dynamic (* avoid infinite loop / should be the same in this context *))
  80. | TLazy f ->
  81. !f()
  82. | TType (t,tl) ->
  83. apply_params t.t_params tl t.t_type
  84. | _ -> t
  85. let t_empty = TAnon({ a_fields = PMap.empty; a_status = ref (Closed) })
  86. let tmp_count = ref 0
  87. let reset_temps () = tmp_count := 0
  88. (* the undefined is a special var that works like null, but can have special meaning *)
  89. let v_undefined = alloc_var "__undefined__" t_dynamic
  90. let undefined pos = { eexpr = TLocal(v_undefined); etype = t_dynamic; epos = pos }
  91. module ExprHashtblHelper =
  92. struct
  93. type hash_texpr_t =
  94. {
  95. hepos : pos;
  96. heexpr : int;
  97. hetype : int;
  98. }
  99. let mk_heexpr = function
  100. | TConst _ -> 0 | TLocal _ -> 1 | TArray _ -> 3 | TBinop _ -> 4 | TField _ -> 5 | TTypeExpr _ -> 7 | TParenthesis _ -> 8 | TObjectDecl _ -> 9
  101. | TArrayDecl _ -> 10 | TCall _ -> 11 | TNew _ -> 12 | TUnop _ -> 13 | TFunction _ -> 14 | TVar _ -> 15 | TBlock _ -> 16 | TFor _ -> 17 | TIf _ -> 18 | TWhile _ -> 19
  102. | TSwitch _ -> 20 (* | TPatMatch _ -> 21 *) | TTry _ -> 22 | TReturn _ -> 23 | TBreak -> 24 | TContinue -> 25 | TThrow _ -> 26 | TCast _ -> 27 | TMeta _ -> 28 | TEnumParameter _ -> 29
  103. let mk_heetype = function
  104. | TMono _ -> 0 | TEnum _ -> 1 | TInst _ -> 2 | TType _ -> 3 | TFun _ -> 4
  105. | TAnon _ -> 5 | TDynamic _ -> 6 | TLazy _ -> 7 | TAbstract _ -> 8
  106. let mk_type e =
  107. {
  108. hepos = e.epos;
  109. heexpr = mk_heexpr e.eexpr;
  110. hetype = mk_heetype e.etype;
  111. }
  112. end;;
  113. let path_of_md_def md_def =
  114. match md_def.m_types with
  115. | [TClassDecl c] -> c.cl_path
  116. | _ -> md_def.m_path
  117. open ExprHashtblHelper;;
  118. (* Expression Hashtbl. This shouldn't be kept indefinately as it's not a weak Hashtbl. *)
  119. module ExprHashtbl = Hashtbl.Make(
  120. struct
  121. type t = Type.texpr
  122. let equal = (==)
  123. let hash t = Hashtbl.hash (mk_type t)
  124. end
  125. );;
  126. (* ******************************************* *)
  127. (* Gen Common
  128. This is the key module for generation of Java and C# sources
  129. In order for both modules to share as much code as possible, some
  130. rules were devised:
  131. - every feature has its own submodule, and may contain the following methods:
  132. - configure
  133. sets all the configuration variables for the module to run. If a module has this method,
  134. it *should* be called once before running any filter
  135. - run_filter ->
  136. runs the filter immediately on the context
  137. - add_filter ->
  138. adds the filter to an expr->expr list. Most filter modules will provide this option so the filter
  139. function can only run once.
  140. - most submodules will have side-effects so the order of operations will matter.
  141. When running configure / add_filter this might be taken care of with the rule-based dispatch system working
  142. underneath, but still there might be some incompatibilities. There will be an effort to document it.
  143. The modules can hint on the order by suffixing their functions with _first or _last.
  144. - any of those methods might have different parameters, that configure how the filter will run.
  145. For example, a simple filter that maps switch() expressions to if () .. else if... might receive
  146. a function that filters what content should be mapped
  147. - Other targets can use those filters on their own code. In order to do that,
  148. a simple configuration step is needed: you need to initialize a generator_ctx type with
  149. Gencommon.new_gen (context:Common.context)
  150. with a generator_ctx context you will be able to add filters to your code, and execute them with
  151. Gencommon.run_filters (gen_context:Gencommon.generator_ctx)
  152. After running the filters, you can run your own generator normally.
  153. (* , or you can run
  154. Gencommon.generate_modules (gen_context:Gencommon.generator_ctx) (extension:string) (module_gen:module_type list->bool)
  155. where module_gen will take a whole module (can be *)
  156. *)
  157. (* ******************************************* *)
  158. (* common helpers *)
  159. (* ******************************************* *)
  160. let assertions = false (* when assertions == true, many assertions will be made to guarantee the quality of the data input *)
  161. let debug_mode = ref false
  162. let trace s = if !debug_mode then print_endline s else ()
  163. let timer name = if !debug_mode then Common.timer name else fun () -> ()
  164. let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false
  165. (* helper function for creating Anon types of class / enum modules *)
  166. let anon_of_classtype cl =
  167. TAnon {
  168. a_fields = cl.cl_statics;
  169. a_status = ref (Statics cl)
  170. }
  171. let anon_of_enum e =
  172. TAnon {
  173. a_fields = PMap.empty;
  174. a_status = ref (EnumStatics e)
  175. }
  176. let anon_of_abstract a =
  177. TAnon {
  178. a_fields = PMap.empty;
  179. a_status = ref (AbstractStatics a)
  180. }
  181. let anon_of_mt mt = match mt with
  182. | TClassDecl cl -> anon_of_classtype cl
  183. | TEnumDecl e -> anon_of_enum e
  184. | TAbstractDecl a -> anon_of_abstract a
  185. | _ -> assert false
  186. let anon_class t =
  187. match follow t with
  188. | TAnon anon ->
  189. (match !(anon.a_status) with
  190. | Statics (cl) -> Some(TClassDecl(cl))
  191. | EnumStatics (e) -> Some(TEnumDecl(e))
  192. | AbstractStatics (a) -> Some(TAbstractDecl(a))
  193. | _ -> None)
  194. | _ -> None
  195. let path_s path =
  196. match path with | ([], s) -> s | (p, s) -> (String.concat "." (fst path)) ^ "." ^ (snd path)
  197. let rec t_to_md t = match t with
  198. | TInst (cl,_) -> TClassDecl cl
  199. | TEnum (e,_) -> TEnumDecl e
  200. | TType (t,_) -> TTypeDecl t
  201. | TAbstract (a,_) -> TAbstractDecl a
  202. | TAnon anon ->
  203. (match !(anon.a_status) with
  204. | EnumStatics e -> TEnumDecl e
  205. | Statics cl -> TClassDecl cl
  206. | AbstractStatics a -> TAbstractDecl a
  207. | _ -> assert false)
  208. | TLazy f -> t_to_md (!f())
  209. | TMono r -> (match !r with | Some t -> t_to_md t | None -> assert false)
  210. | _ -> assert false
  211. let get_cl mt = match mt with | TClassDecl cl -> cl | _ -> failwith ("Unexpected module type of '" ^ path_s (t_path mt) ^ "'")
  212. let get_abstract mt = match mt with | TAbstractDecl a -> a | _ -> failwith ("Unexpected module type of '" ^ path_s (t_path mt) ^ "'")
  213. let get_tdef mt = match mt with | TTypeDecl t -> t | _ -> assert false
  214. let mk_mt_access mt pos = { eexpr = TTypeExpr(mt); etype = anon_of_mt mt; epos = pos }
  215. let is_void t = match follow t with
  216. | TAbstract ({ a_path = ([], "Void") },[]) ->
  217. true
  218. | _ -> false
  219. let mk_local var pos = { eexpr = TLocal(var); etype = var.v_type; epos = pos }
  220. (* this function is used by CastDetection module *)
  221. let get_fun t =
  222. match follow t with | TFun(r1,r2) -> (r1,r2) | _ -> (trace (s_type (print_context()) (follow t) )); assert false
  223. let mk_cast t e =
  224. { eexpr = TCast(e, None); etype = t; epos = e.epos }
  225. let mk_classtype_access cl pos =
  226. { eexpr = TTypeExpr(TClassDecl(cl)); etype = anon_of_classtype cl; epos = pos }
  227. let mk_static_field_access_infer cl field pos params =
  228. try
  229. let cf = (PMap.find field cl.cl_statics) in
  230. { eexpr = TField(mk_classtype_access cl pos, FStatic(cl, cf)); etype = (if params = [] then cf.cf_type else apply_params cf.cf_params params cf.cf_type); epos = pos }
  231. with | Not_found -> failwith ("Cannot find field " ^ field ^ " in type " ^ (path_s cl.cl_path))
  232. let mk_static_field_access cl field fieldt pos =
  233. { (mk_static_field_access_infer cl field pos []) with etype = fieldt }
  234. (* stolen from Hugh's sources ;-) *)
  235. (* this used to be a class, but there was something in there that crashed ocaml native compiler in windows *)
  236. module SourceWriter =
  237. struct
  238. type source_writer =
  239. {
  240. sw_buf : Buffer.t;
  241. mutable sw_has_content : bool;
  242. mutable sw_indent : string;
  243. mutable sw_indents : string list;
  244. }
  245. let new_source_writer () =
  246. {
  247. sw_buf = Buffer.create 0;
  248. sw_has_content = false;
  249. sw_indent = "";
  250. sw_indents = [];
  251. }
  252. let add_writer w_write w_read = Buffer.add_buffer w_read.sw_buf w_write.sw_buf
  253. let contents w = Buffer.contents w.sw_buf
  254. let len w = Buffer.length w.sw_buf
  255. let write w x =
  256. (if not w.sw_has_content then begin w.sw_has_content <- true; Buffer.add_string w.sw_buf w.sw_indent; Buffer.add_string w.sw_buf x; end else Buffer.add_string w.sw_buf x);
  257. let len = (String.length x)-1 in
  258. if len >= 0 && String.get x len = '\n' then begin w.sw_has_content <- false end else w.sw_has_content <- true
  259. let push_indent w = w.sw_indents <- "\t"::w.sw_indents; w.sw_indent <- String.concat "" w.sw_indents
  260. let pop_indent w =
  261. match w.sw_indents with
  262. | h::tail -> w.sw_indents <- tail; w.sw_indent <- String.concat "" w.sw_indents
  263. | [] -> w.sw_indent <- "/*?*/"
  264. let newline w = write w "\n"
  265. let begin_block w = (if w.sw_has_content then newline w); write w "{"; push_indent w; newline w
  266. let end_block w = pop_indent w; (if w.sw_has_content then newline w); write w "}"; newline w
  267. let print w =
  268. (if not w.sw_has_content then begin w.sw_has_content <- true; Buffer.add_string w.sw_buf w.sw_indent end);
  269. bprintf w.sw_buf;
  270. end;;
  271. (* rule_dispatcher's priority *)
  272. type priority =
  273. | PFirst
  274. | PLast
  275. | PZero
  276. | PCustom of float
  277. exception DuplicateName of string
  278. exception NoRulesApplied
  279. let indent = ref []
  280. (* the rule dispatcher is the primary way to deal with distributed "plugins" *)
  281. (* we will define rules that will form a distributed / extensible match system *)
  282. class ['tp, 'ret] rule_dispatcher name ignore_not_found =
  283. object(self)
  284. val tbl = Hashtbl.create 16
  285. val mutable keys = []
  286. val names = Hashtbl.create 16
  287. val mutable temp = 0
  288. method add ?(name : string option) (* name helps debugging *) ?(priority : priority = PZero) (rule : 'tp->'ret option) =
  289. let p = match priority with
  290. | PFirst -> infinity
  291. | PLast -> neg_infinity
  292. | PZero -> 0.0
  293. | PCustom i -> i
  294. in
  295. let q = if not( Hashtbl.mem tbl p ) then begin
  296. let q = Stack.create() in
  297. Hashtbl.add tbl p q;
  298. keys <- p :: keys;
  299. keys <- List.sort (fun x y -> - (compare x y)) keys;
  300. q
  301. end else Hashtbl.find tbl p in
  302. let name = match name with
  303. | None -> temp <- temp + 1; "$_" ^ (string_of_int temp)
  304. | Some s -> s
  305. in
  306. (if Hashtbl.mem names name then raise (DuplicateName(name)));
  307. Hashtbl.add names name q;
  308. Stack.push (name, rule) q
  309. method describe =
  310. Hashtbl.iter (fun s _ -> (trace s)) names;
  311. method remove (name : string) =
  312. if Hashtbl.mem names name then begin
  313. let q = Hashtbl.find names name in
  314. let q_temp = Stack.create () in
  315. Stack.iter (function
  316. | (n, _) when n = name -> ()
  317. | _ as r -> Stack.push r q_temp
  318. ) q;
  319. Stack.clear q;
  320. Stack.iter (fun r -> Stack.push r q) q_temp;
  321. Hashtbl.remove names name;
  322. true
  323. end else false
  324. method run_f tp = get (self#run tp)
  325. method did_run tp = is_some (self#run tp)
  326. method get_list =
  327. let ret = ref [] in
  328. List.iter (fun key ->
  329. let q = Hashtbl.find tbl key in
  330. Stack.iter (fun (_, rule) -> ret := rule :: !ret) q
  331. ) keys;
  332. List.rev !ret
  333. method run_from (priority:float) (tp:'tp) : 'ret option =
  334. let ok = ref ignore_not_found in
  335. let ret = ref None in
  336. indent := "\t" :: !indent;
  337. (try begin
  338. List.iter (fun key ->
  339. if key < priority then begin
  340. let q = Hashtbl.find tbl key in
  341. Stack.iter (fun (n, rule) ->
  342. let t = if !debug_mode then Common.timer ("rule dispatcher rule: " ^ n) else fun () -> () in
  343. let r = rule(tp) in
  344. t();
  345. if is_some r then begin ret := r; raise Exit end
  346. ) q
  347. end
  348. ) keys
  349. end with Exit -> ok := true);
  350. (match !indent with
  351. | [] -> ()
  352. | h::t -> indent := t);
  353. (if not (!ok) then raise NoRulesApplied);
  354. !ret
  355. method run (tp:'tp) : 'ret option =
  356. self#run_from infinity tp
  357. end;;
  358. (* this is a special case where tp = tret and you stack their output as the next's input *)
  359. class ['tp] rule_map_dispatcher name =
  360. object(self)
  361. inherit ['tp, 'tp] rule_dispatcher name true as super
  362. method run_f tp = get (self#run tp)
  363. method run_from (priority:float) (tp:'tp) : 'ret option =
  364. let cur = ref tp in
  365. (try begin
  366. List.iter (fun key ->
  367. if key < priority then begin
  368. let q = Hashtbl.find tbl key in
  369. Stack.iter (fun (n, rule) ->
  370. trace ("running rule " ^ n);
  371. let t = if !debug_mode then Common.timer ("rule map dispatcher rule: " ^ n) else fun () -> () in
  372. let r = rule(!cur) in
  373. t();
  374. if is_some r then begin cur := get r end
  375. ) q
  376. end
  377. ) keys
  378. end with Exit -> ());
  379. Some (!cur)
  380. end;;
  381. type generator_ctx =
  382. {
  383. (* these are the basic context fields. If another target is using this context, *)
  384. (* this is all you need to care about *)
  385. mutable gcon : Common.context;
  386. gclasses : gen_classes;
  387. gtools : gen_tools;
  388. (*
  389. configurable function that receives a desired name and makes it "internal", doing the best
  390. to ensure that it will not be called from outside.
  391. To avoid name clashes between internal names, user must specify two strings: a "namespace" and the name itself
  392. *)
  393. mutable gmk_internal_name : string->string->string;
  394. (*
  395. module filters run before module filters and they should generate valid haxe syntax as a result.
  396. Module filters shouldn't go through the expressions as it adds an unnecessary burden to the GC,
  397. and it can all be done in a single step with gexpr_filters and proper priority selection.
  398. As a convention, Module filters should end their name with Modf, so they aren't mistaken with expression filters
  399. *)
  400. gmodule_filters : (module_type) rule_map_dispatcher;
  401. (*
  402. expression filters are the most common filters to be applied.
  403. They should also generate only valid haxe expressions, so e.g. calls to non-existant methods
  404. should be avoided, although there are some ways around them (like gspecial_methods)
  405. *)
  406. gexpr_filters : (texpr) rule_map_dispatcher;
  407. (*
  408. syntax filters are also expression filters but they no longer require
  409. that the resulting expressions be valid haxe expressions.
  410. They then have no guarantee that either the input expressions or the output one follow the same
  411. rules as normal haxe code.
  412. *)
  413. gsyntax_filters : (texpr) rule_map_dispatcher;
  414. (* these are more advanced features, but they would require a rewrite of targets *)
  415. (* they are just helpers to ditribute functions like "follow" or "type to string" *)
  416. (* so adding a module will already take care of correctly following a certain type of *)
  417. (* variable, for example *)
  418. (* follows the type through typedefs, lazy typing, etc. *)
  419. (* it's the place to put specific rules to handle typedefs, like *)
  420. (* other basic types like UInt *)
  421. gfollow : (t, t) rule_dispatcher;
  422. gtypes : (path, module_type) Hashtbl.t;
  423. mutable gtypes_list : module_type list;
  424. mutable gmodules : Type.module_def list;
  425. (* cast detection helpers / settings *)
  426. (* this is a cache for all field access types *)
  427. greal_field_types : (path * string, (tclass_field (* does the cf exist *) * t (*cf's type in relation to current class type params *) * t * tclass (* declared class *) ) option) Hashtbl.t;
  428. (* this function allows any code to handle casts as if it were inside the cast_detect module *)
  429. mutable ghandle_cast : t->t->texpr->texpr;
  430. (* when an unsafe cast is made, we can warn the user *)
  431. mutable gon_unsafe_cast : t->t->pos->unit;
  432. (* does this type needs to be boxed? Normally always false, unless special type handling must be made *)
  433. mutable gneeds_box : t->bool;
  434. (* does this 'special type' needs cast to this other type? *)
  435. (* this is here so we can implement custom behavior for "opaque" typedefs *)
  436. mutable gspecial_needs_cast : t->t->bool;
  437. (* sometimes we may want to support unrelated conversions on cast detection *)
  438. (* for example, haxe.lang.Null<T> -> T on C# *)
  439. (* every time an unrelated conversion is found, each to/from path is searched on this hashtbl *)
  440. (* if found, the function will be executed with from_type, to_type. If returns true, it means that *)
  441. (* it is a supported conversion, and the unsafe cast routine changes to a simple cast *)
  442. gsupported_conversions : (path, t->t->bool) Hashtbl.t;
  443. (* API for filters *)
  444. (* add type can be called at any time, and will add a new module_def that may or may not be filtered *)
  445. (* module_type -> should_filter *)
  446. mutable gadd_type : module_type -> bool -> unit;
  447. (* during expr filters, add_to_module will be available so module_types can be added to current module_def. we must pass the priority argument so the filters can be resumed *)
  448. mutable gadd_to_module : module_type -> float -> unit;
  449. (* during expr filters, shows the current class path *)
  450. mutable gcurrent_path : path;
  451. (* current class *)
  452. mutable gcurrent_class : tclass option;
  453. (* current class field, if any *)
  454. mutable gcurrent_classfield : tclass_field option;
  455. (* events *)
  456. (* is executed once every new classfield *)
  457. mutable gon_classfield_start : (unit -> unit) list;
  458. (* is executed once every new module type *)
  459. mutable gon_new_module_type : (unit -> unit) list;
  460. (* after module filters ended *)
  461. mutable gafter_mod_filters_ended : (unit -> unit) list;
  462. (* after expression filters ended *)
  463. mutable gafter_expr_filters_ended : (unit -> unit) list;
  464. (* after all filters are run *)
  465. mutable gafter_filters_ended : (unit -> unit) list;
  466. mutable gbase_class_fields : (string, tclass_field) PMap.t;
  467. (* real type is the type as it is read by the target. *)
  468. (* This function is here because most targets don't have *)
  469. (* a 1:1 translation between haxe types and its native types *)
  470. (* But types aren't changed to this representation as we might lose *)
  471. (* some valuable type information in the process *)
  472. mutable greal_type : t -> t;
  473. (*
  474. the same as greal_type but for type parameters.
  475. *)
  476. mutable greal_type_param : module_type -> tparams -> tparams;
  477. (*
  478. is the type a value type?
  479. This may be used in some optimizations where reference types and value types
  480. are handled differently. At first the default is very good to use, and if tweaks are needed,
  481. it's best to be done by adding @:struct meta to the value types
  482. *
  483. mutable gis_value_type : t -> bool;*)
  484. (* misc configuration *)
  485. (*
  486. Should the target allow type parameter dynamic conversion,
  487. or should we add a cast to those cases as well?
  488. *)
  489. mutable gallow_tp_dynamic_conversion : bool;
  490. (*
  491. Does the target support type parameter constraints?
  492. If not, they will be ignored when detecting casts
  493. *)
  494. mutable guse_tp_constraints : bool;
  495. (* internal apis *)
  496. (* param_func_call : used by TypeParams and CastDetection *)
  497. mutable gparam_func_call : texpr->texpr->tparams->texpr list->texpr;
  498. (* does it already have a type parameter cast handler? This is used by CastDetect to know if it should handle type parameter casts *)
  499. mutable ghas_tparam_cast_handler : bool;
  500. (* type parameter casts - special cases *)
  501. (* function cast_from, cast_to -> texpr *)
  502. gtparam_cast : (path, (texpr->t->texpr)) Hashtbl.t;
  503. (*
  504. special vars are used for adding special behavior to
  505. *)
  506. gspecial_vars : (string, bool) Hashtbl.t;
  507. }
  508. and gen_classes =
  509. {
  510. cl_reflect : tclass;
  511. cl_type : tclass;
  512. cl_dyn : tclass;
  513. t_iterator : tdef;
  514. mutable nativearray_len : texpr -> pos -> texpr;
  515. mutable nativearray_type : Type.t -> Type.t;
  516. mutable nativearray : Type.t -> Type.t;
  517. }
  518. (* add here all reflection transformation additions *)
  519. and gen_tools =
  520. {
  521. (* (klass : texpr, t : t) : texpr *)
  522. mutable r_create_empty : texpr->t->texpr;
  523. (* Reflect.fields(). The bool is if we are iterating in a read-only manner. If it is read-only we might not need to allocate a new array *)
  524. mutable r_fields : bool->texpr->texpr;
  525. (* (first argument = return type. should be void in most cases) Reflect.setField(obj, field, val) *)
  526. mutable r_set_field : t->texpr->texpr->texpr->texpr;
  527. (* Reflect.field. bool indicates if is safe (no error throwing) or unsafe; t is the expected return type true = safe *)
  528. mutable r_field : bool->t->texpr->texpr->texpr;
  529. (*
  530. these are now the functions that will later be used when creating the reflection classes
  531. *)
  532. (* on the default implementation (at OverloadingCtors), it will be new SomeClass<params>(EmptyInstance) *)
  533. mutable rf_create_empty : tclass->tparams->pos->texpr;
  534. }
  535. let get_type types path =
  536. List.find (fun md -> match md with
  537. | TClassDecl cl when cl.cl_path = path -> true
  538. | TEnumDecl e when e.e_path = path -> true
  539. | TTypeDecl t when t.t_path = path -> true
  540. | TAbstractDecl a when a.a_path = path -> true
  541. | _ -> false
  542. ) types
  543. let new_ctx con =
  544. let types = Hashtbl.create (List.length con.types) in
  545. List.iter (fun mt ->
  546. match mt with
  547. | TClassDecl cl -> Hashtbl.add types cl.cl_path mt
  548. | TEnumDecl e -> Hashtbl.add types e.e_path mt
  549. | TTypeDecl t -> Hashtbl.add types t.t_path mt
  550. | TAbstractDecl a -> Hashtbl.add types a.a_path mt
  551. ) con.types;
  552. let cl_dyn = match get_type con.types ([], "Dynamic") with
  553. | TClassDecl c -> c
  554. | TAbstractDecl a ->
  555. mk_class a.a_module ([], "Dynamic") a.a_pos
  556. | _ -> assert false
  557. in
  558. let rec gen = {
  559. gcon = con;
  560. gclasses = {
  561. cl_reflect = get_cl (get_type con.types ([], "Reflect"));
  562. cl_type = get_cl (get_type con.types ([], "Type"));
  563. cl_dyn = cl_dyn;
  564. t_iterator = get_tdef (get_type con.types ([], "Iterator"));
  565. nativearray = (fun _ -> assert false);
  566. nativearray_type = (fun _ -> assert false);
  567. nativearray_len = (fun _ -> assert false);
  568. };
  569. gtools = {
  570. r_create_empty = (fun eclass t ->
  571. let fieldcall = mk_static_field_access_infer gen.gclasses.cl_type "createEmptyInstance" eclass.epos [t] in
  572. { eexpr = TCall(fieldcall, [eclass]); etype = t; epos = eclass.epos }
  573. );
  574. r_fields = (fun is_used_only_by_iteration expr ->
  575. let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "fields" expr.epos [] in
  576. { eexpr = TCall(fieldcall, [expr]); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = expr.epos }
  577. );
  578. (* Reflect.setField(obj, field, val). t by now is ignored. FIXME : fix this implementation *)
  579. r_set_field = (fun t obj field v ->
  580. let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "setField" v.epos [] in
  581. { eexpr = TCall(fieldcall, [obj; field; v]); etype = t_dynamic; epos = v.epos }
  582. );
  583. (* Reflect.field. bool indicates if is safe (no error throwing) or unsafe. true = safe *)
  584. r_field = (fun is_safe t obj field ->
  585. let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "field" obj.epos [] in
  586. (* FIXME: should we see if needs to cast? *)
  587. mk_cast t { eexpr = TCall(fieldcall, [obj; field]); etype = t_dynamic; epos = obj.epos }
  588. );
  589. rf_create_empty = (fun cl p pos ->
  590. gen.gtools.r_create_empty { eexpr = TTypeExpr(TClassDecl cl); epos = pos; etype = t_dynamic } (TInst(cl,p))
  591. ); (* TODO: Maybe implement using normal reflection? Type.createEmpty(MyClass) *)
  592. };
  593. gmk_internal_name = (fun ns s -> sprintf "__%s_%s" ns s);
  594. gexpr_filters = new rule_map_dispatcher "gexpr_filters";
  595. gmodule_filters = new rule_map_dispatcher "gmodule_filters";
  596. gsyntax_filters = new rule_map_dispatcher "gsyntax_filters";
  597. gfollow = new rule_dispatcher "gfollow" false;
  598. gtypes = types;
  599. gtypes_list = con.types;
  600. gmodules = con.modules;
  601. greal_field_types = Hashtbl.create 0;
  602. ghandle_cast = (fun to_t from_t e -> mk_cast to_t e);
  603. gon_unsafe_cast = (fun t t2 pos -> (gen.gcon.warning ("Type " ^ (debug_type t2) ^ " is being cast to the unrelated type " ^ (s_type (print_context()) t)) pos));
  604. gneeds_box = (fun t -> false);
  605. gspecial_needs_cast = (fun to_t from_t -> true);
  606. gsupported_conversions = Hashtbl.create 0;
  607. gadd_type = (fun md should_filter ->
  608. if should_filter then begin
  609. gen.gtypes_list <- md :: gen.gtypes_list;
  610. gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: gen.gmodules;
  611. Hashtbl.add gen.gtypes (t_path md) md;
  612. end else gen.gafter_filters_ended <- (fun () ->
  613. gen.gtypes_list <- md :: gen.gtypes_list;
  614. gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: gen.gmodules;
  615. Hashtbl.add gen.gtypes (t_path md) md;
  616. ) :: gen.gafter_filters_ended;
  617. );
  618. gadd_to_module = (fun md pr -> failwith "module added outside expr filters");
  619. gcurrent_path = ([],"");
  620. gcurrent_class = None;
  621. gcurrent_classfield = None;
  622. gon_classfield_start = [];
  623. gon_new_module_type = [];
  624. gafter_mod_filters_ended = [];
  625. gafter_expr_filters_ended = [];
  626. gafter_filters_ended = [];
  627. gbase_class_fields = PMap.empty;
  628. greal_type = (fun t -> t);
  629. greal_type_param = (fun _ t -> t);
  630. gallow_tp_dynamic_conversion = false;
  631. guse_tp_constraints = false;
  632. (* as a default, ignore the params *)
  633. gparam_func_call = (fun ecall efield params elist -> { ecall with eexpr = TCall(efield, elist) });
  634. ghas_tparam_cast_handler = false;
  635. gtparam_cast = Hashtbl.create 0;
  636. gspecial_vars = Hashtbl.create 0;
  637. } in
  638. (*gen.gtools.r_create_empty <-
  639. gen.gtools.r_get_class <-
  640. gen.gtools.r_fields <- *)
  641. gen
  642. let init_ctx gen =
  643. (* ultimately add a follow once handler as the last follow handler *)
  644. let follow_f = gen.gfollow#run in
  645. let follow t =
  646. match t with
  647. | TMono r ->
  648. (match !r with
  649. | Some t -> follow_f t
  650. | _ -> Some t)
  651. | TLazy f ->
  652. follow_f (!f())
  653. | TType (t,tl) ->
  654. follow_f (apply_params t.t_params tl t.t_type)
  655. | _ -> Some t
  656. in
  657. gen.gfollow#add ~name:"final" ~priority:PLast follow
  658. (* run_follow (gen:generator_ctx) (t:t) *)
  659. let run_follow gen = gen.gfollow#run_f
  660. let reorder_modules gen =
  661. let modules = Hashtbl.create 20 in
  662. List.iter (fun md ->
  663. Hashtbl.add modules ( (t_infos md).mt_module ).m_path md
  664. ) gen.gtypes_list;
  665. gen.gmodules <- [];
  666. let processed = Hashtbl.create 20 in
  667. Hashtbl.iter (fun md_path md ->
  668. if not (Hashtbl.mem processed md_path) then begin
  669. Hashtbl.add processed md_path true;
  670. gen.gmodules <- { m_id = alloc_mid(); m_path = md_path; m_types = List.rev ( Hashtbl.find_all modules md_path ); m_extra = (t_infos md).mt_module.m_extra } :: gen.gmodules
  671. end
  672. ) modules
  673. let run_filters_from gen t filters =
  674. match t with
  675. | TClassDecl c ->
  676. trace (snd c.cl_path);
  677. gen.gcurrent_path <- c.cl_path;
  678. gen.gcurrent_class <- Some(c);
  679. List.iter (fun fn -> fn()) gen.gon_new_module_type;
  680. gen.gcurrent_classfield <- None;
  681. let rec process_field f =
  682. reset_temps();
  683. gen.gcurrent_classfield <- Some(f);
  684. List.iter (fun fn -> fn()) gen.gon_classfield_start;
  685. trace f.cf_name;
  686. (match f.cf_expr with
  687. | None -> ()
  688. | Some e ->
  689. f.cf_expr <- Some (List.fold_left (fun e f -> f e) e filters));
  690. List.iter process_field f.cf_overloads;
  691. in
  692. List.iter process_field c.cl_ordered_fields;
  693. List.iter process_field c.cl_ordered_statics;
  694. (match c.cl_constructor with
  695. | None -> ()
  696. | Some f -> process_field f);
  697. gen.gcurrent_classfield <- None;
  698. (match c.cl_init with
  699. | None -> ()
  700. | Some e ->
  701. c.cl_init <- Some (List.fold_left (fun e f -> f e) e filters));
  702. | TEnumDecl _ -> ()
  703. | TTypeDecl _ -> ()
  704. | TAbstractDecl _ -> ()
  705. let run_filters gen =
  706. let last_error = gen.gcon.error in
  707. let has_errors = ref false in
  708. gen.gcon.error <- (fun msg pos -> has_errors := true; last_error msg pos);
  709. (* first of all, we have to make sure that the filters won't trigger a major Gc collection *)
  710. let t = Common.timer "gencommon_filters" in
  711. (if Common.defined gen.gcon Define.GencommonDebug then debug_mode := true else debug_mode := false);
  712. let run_filters filter =
  713. let rec loop acc mds =
  714. match mds with
  715. | [] -> acc
  716. | md :: tl ->
  717. let filters = [ filter#run_f ] in
  718. let added_types = ref [] in
  719. gen.gadd_to_module <- (fun md_type priority ->
  720. gen.gtypes_list <- md_type :: gen.gtypes_list;
  721. added_types := (md_type, priority) :: !added_types
  722. );
  723. run_filters_from gen md filters;
  724. let added_types = List.map (fun (t,p) ->
  725. run_filters_from gen t [ fun e -> get (filter#run_from p e) ];
  726. if Hashtbl.mem gen.gtypes (t_path t) then begin
  727. let rec loop i =
  728. let p = t_path t in
  729. let new_p = (fst p, snd p ^ "_" ^ (string_of_int i)) in
  730. if Hashtbl.mem gen.gtypes new_p then
  731. loop (i+1)
  732. else
  733. match t with
  734. | TClassDecl cl -> cl.cl_path <- new_p
  735. | TEnumDecl e -> e.e_path <- new_p
  736. | TTypeDecl _ | TAbstractDecl _ -> ()
  737. in
  738. loop 0
  739. end;
  740. Hashtbl.add gen.gtypes (t_path t) t;
  741. t
  742. ) !added_types in
  743. loop (added_types @ (md :: acc)) tl
  744. in
  745. List.rev (loop [] gen.gtypes_list)
  746. in
  747. let run_mod_filter filter =
  748. let last_add_to_module = gen.gadd_to_module in
  749. let added_types = ref [] in
  750. gen.gadd_to_module <- (fun md_type priority ->
  751. Hashtbl.add gen.gtypes (t_path md_type) md_type;
  752. added_types := (md_type, priority) :: !added_types
  753. );
  754. let rec loop processed not_processed =
  755. match not_processed with
  756. | hd :: tl ->
  757. (match hd with
  758. | TClassDecl c ->
  759. gen.gcurrent_class <- Some c
  760. | _ ->
  761. gen.gcurrent_class <- None);
  762. let new_hd = filter#run_f hd in
  763. let added_types_new = !added_types in
  764. added_types := [];
  765. let added_types = List.map (fun (t,p) ->
  766. get (filter#run_from p t)
  767. ) added_types_new in
  768. loop ( added_types @ (new_hd :: processed) ) tl
  769. | [] ->
  770. processed
  771. in
  772. let filtered = loop [] gen.gtypes_list in
  773. gen.gadd_to_module <- last_add_to_module;
  774. gen.gtypes_list <- List.rev (filtered)
  775. in
  776. run_mod_filter gen.gmodule_filters;
  777. List.iter (fun fn -> fn()) gen.gafter_mod_filters_ended;
  778. let last_add_to_module = gen.gadd_to_module in
  779. gen.gtypes_list <- run_filters gen.gexpr_filters;
  780. gen.gadd_to_module <- last_add_to_module;
  781. List.iter (fun fn -> fn()) gen.gafter_expr_filters_ended;
  782. (* Codegen.post_process gen.gtypes_list [gen.gexpr_filters#run_f]; *)
  783. gen.gtypes_list <- run_filters gen.gsyntax_filters;
  784. List.iter (fun fn -> fn()) gen.gafter_filters_ended;
  785. reorder_modules gen;
  786. t();
  787. if !has_errors then raise (Abort("Compilation aborted with errors",null_pos))
  788. (* ******************************************* *)
  789. (* basic generation module that source code compilation implementations can use *)
  790. (* ******************************************* *)
  791. let write_file gen w source_dir path extension out_files =
  792. let t = timer "write file" in
  793. let s_path = source_dir ^ "/" ^ (snd path) ^ "." ^ (extension) in
  794. (* create the folders if they don't exist *)
  795. mkdir_from_path s_path;
  796. let contents = SourceWriter.contents w in
  797. let should_write = if not (Common.defined gen.gcon Define.ReplaceFiles) && Sys.file_exists s_path then begin
  798. let in_file = open_in s_path in
  799. let old_contents = Std.input_all in_file in
  800. close_in in_file;
  801. contents <> old_contents
  802. end else true in
  803. if should_write then begin
  804. let f = open_out_bin s_path in
  805. output_string f contents;
  806. close_out f
  807. end;
  808. out_files := (unique_full_path s_path) :: !out_files;
  809. t()
  810. let clean_files path excludes verbose =
  811. let rec iter_files pack dir path = try
  812. let file = Unix.readdir dir in
  813. if file <> "." && file <> ".." then begin
  814. let filepath = path ^ "/" ^ file in
  815. if (Unix.stat filepath).st_kind = S_DIR then
  816. let pack = pack @ [file] in
  817. iter_files (pack) (Unix.opendir filepath) filepath;
  818. try Unix.rmdir filepath with Unix.Unix_error (ENOTEMPTY,_,_) -> ();
  819. else if not (String.ends_with filepath ".meta") && not (List.mem (unique_full_path filepath) excludes) then begin
  820. if verbose then print_endline ("Removing " ^ filepath);
  821. Sys.remove filepath
  822. end
  823. end;
  824. iter_files pack dir path
  825. with | End_of_file | Unix.Unix_error _ ->
  826. Unix.closedir dir
  827. in
  828. iter_files [] (Unix.opendir path) path
  829. let dump_descriptor gen name path_s module_s =
  830. let w = SourceWriter.new_source_writer () in
  831. (* dump called path *)
  832. SourceWriter.write w (Sys.getcwd());
  833. SourceWriter.newline w;
  834. (* dump all defines. deprecated *)
  835. SourceWriter.write w "begin defines";
  836. SourceWriter.newline w;
  837. PMap.iter (fun name _ ->
  838. SourceWriter.write w name;
  839. SourceWriter.newline w
  840. ) gen.gcon.defines;
  841. SourceWriter.write w "end defines";
  842. SourceWriter.newline w;
  843. (* dump all defines with their values; keeping the old defines for compatibility *)
  844. SourceWriter.write w "begin defines_data";
  845. SourceWriter.newline w;
  846. PMap.iter (fun name v ->
  847. SourceWriter.write w name;
  848. SourceWriter.write w "=";
  849. SourceWriter.write w v;
  850. SourceWriter.newline w
  851. ) gen.gcon.defines;
  852. SourceWriter.write w "end defines_data";
  853. SourceWriter.newline w;
  854. (* dump all generated types *)
  855. SourceWriter.write w "begin modules";
  856. SourceWriter.newline w;
  857. let main_paths = Hashtbl.create 0 in
  858. List.iter (fun md_def ->
  859. SourceWriter.write w "M ";
  860. SourceWriter.write w (path_s (path_of_md_def md_def));
  861. SourceWriter.newline w;
  862. List.iter (fun m ->
  863. match m with
  864. | TClassDecl cl when not cl.cl_extern ->
  865. SourceWriter.write w "C ";
  866. let s = module_s m in
  867. Hashtbl.add main_paths cl.cl_path s;
  868. SourceWriter.write w (s);
  869. SourceWriter.newline w
  870. | TEnumDecl e when not e.e_extern ->
  871. SourceWriter.write w "E ";
  872. SourceWriter.write w (module_s m);
  873. SourceWriter.newline w
  874. | _ -> () (* still no typedef or abstract is generated *)
  875. ) md_def.m_types
  876. ) gen.gmodules;
  877. SourceWriter.write w "end modules";
  878. SourceWriter.newline w;
  879. (* dump all resources *)
  880. (match gen.gcon.main_class with
  881. | Some path ->
  882. SourceWriter.write w "begin main";
  883. SourceWriter.newline w;
  884. (try
  885. SourceWriter.write w (Hashtbl.find main_paths path)
  886. with
  887. | Not_found -> SourceWriter.write w (path_s path));
  888. SourceWriter.newline w;
  889. SourceWriter.write w "end main";
  890. SourceWriter.newline w
  891. | _ -> ()
  892. );
  893. SourceWriter.write w "begin resources";
  894. SourceWriter.newline w;
  895. Hashtbl.iter (fun name _ ->
  896. SourceWriter.write w name;
  897. SourceWriter.newline w
  898. ) gen.gcon.resources;
  899. SourceWriter.write w "end resources";
  900. SourceWriter.newline w;
  901. SourceWriter.write w "begin libs";
  902. SourceWriter.newline w;
  903. let path file ext =
  904. if Sys.file_exists file then
  905. file
  906. else try Common.find_file gen.gcon file with
  907. | Not_found -> try Common.find_file gen.gcon (file ^ ext) with
  908. | Not_found ->
  909. file
  910. in
  911. if Common.platform gen.gcon Java then
  912. List.iter (fun (s,std,_,_,_) ->
  913. if not std then begin
  914. SourceWriter.write w (path s ".jar");
  915. SourceWriter.newline w;
  916. end
  917. ) gen.gcon.java_libs
  918. else if Common.platform gen.gcon Cs then
  919. List.iter (fun (s,std,_,_) ->
  920. if not std then begin
  921. SourceWriter.write w (path s ".dll");
  922. SourceWriter.newline w;
  923. end
  924. ) gen.gcon.net_libs;
  925. SourceWriter.write w "end libs";
  926. SourceWriter.newline w;
  927. let args = gen.gcon.c_args in
  928. if args <> [] then begin
  929. SourceWriter.write w "begin opts";
  930. SourceWriter.newline w;
  931. List.iter (fun opt -> SourceWriter.write w opt; SourceWriter.newline w) (List.rev args);
  932. SourceWriter.write w "end opts";
  933. SourceWriter.newline w;
  934. end;
  935. let contents = SourceWriter.contents w in
  936. let f = open_out (gen.gcon.file ^ "/" ^ name) in
  937. output_string f contents;
  938. close_out f
  939. let path_regex = Str.regexp "[/\\]+"
  940. let normalize path =
  941. let rec normalize acc m = match m with
  942. | [] ->
  943. List.rev acc
  944. | Str.Text "." :: Str.Delim _ :: tl when acc = [] ->
  945. normalize [] tl
  946. | Str.Text ".." :: Str.Delim _ :: tl -> (match acc with
  947. | [] -> raise Exit
  948. | _ :: acc -> normalize acc tl)
  949. | Str.Text t :: Str.Delim _ :: tl ->
  950. normalize (t :: acc) tl
  951. | Str.Delim _ :: tl ->
  952. normalize ("" :: acc) tl
  953. | Str.Text t :: [] ->
  954. List.rev (t :: acc)
  955. | Str.Text _ :: Str.Text _ :: _ -> assert false
  956. in
  957. String.concat "/" (normalize [] (Str.full_split path_regex path))
  958. let is_relative cwd rel =
  959. try
  960. let rel = normalize rel in
  961. Filename.is_relative rel || (String.starts_with rel cwd || String.starts_with (Common.unique_full_path rel) cwd)
  962. with | Exit ->
  963. String.starts_with rel cwd || String.starts_with (Common.unique_full_path rel) cwd
  964. (*
  965. helper function to create the source structure. Will send each module_def to the function passed.
  966. If received true, it means that module_gen has generated this content, so the file must be saved.
  967. See that it will write a whole module
  968. *)
  969. let generate_modules gen extension source_dir (module_gen : SourceWriter.source_writer->module_def->bool) out_files =
  970. List.iter (fun md_def ->
  971. let source_dir =
  972. gen.gcon.file ^ "/" ^ source_dir ^ "/" ^ (String.concat "/" (fst (path_of_md_def md_def)))
  973. in
  974. let w = SourceWriter.new_source_writer () in
  975. (*let should_write = List.fold_left (fun should md -> module_gen w md or should) false md_def.m_types in*)
  976. let should_write = module_gen w md_def in
  977. if should_write then begin
  978. let path = path_of_md_def md_def in
  979. write_file gen w source_dir path extension out_files
  980. end
  981. ) gen.gmodules
  982. let generate_modules_t gen extension source_dir change_path (module_gen : SourceWriter.source_writer->module_type->bool) out_files =
  983. let source_dir = gen.gcon.file ^ "/" ^ source_dir in
  984. List.iter (fun md ->
  985. let w = SourceWriter.new_source_writer () in
  986. (*let should_write = List.fold_left (fun should md -> module_gen w md or should) false md_def.m_types in*)
  987. let should_write = module_gen w md in
  988. if should_write then begin
  989. let path = change_path (t_path md) in
  990. write_file gen w (source_dir ^ "/" ^ (String.concat "/" (fst path))) path extension out_files;
  991. end
  992. ) gen.gtypes_list
  993. (*
  994. various helper functions
  995. *)
  996. let mk_paren e =
  997. match e.eexpr with | TParenthesis _ -> e | _ -> { e with eexpr=TParenthesis(e) }
  998. (* private *)
  999. let get_real_fun gen t =
  1000. match follow t with
  1001. | TFun(args,t) -> TFun(List.map (fun (n,o,t) -> n,o,gen.greal_type t) args, gen.greal_type t)
  1002. | _ -> t
  1003. let mk_int gen i pos = { eexpr = TConst(TInt ( Int32.of_int i)); etype = gen.gcon.basic.tint; epos = pos }
  1004. let mk_return e = { eexpr = TReturn (Some e); etype = e.etype; epos = e.epos }
  1005. let mk_temp gen name t =
  1006. incr tmp_count;
  1007. let name = gen.gmk_internal_name "temp" (name ^ (string_of_int !tmp_count)) in
  1008. alloc_var name t
  1009. let v_nativearray = alloc_var "__array__" t_dynamic
  1010. let mk_nativearray_decl gen t el pos =
  1011. {
  1012. eexpr = TCall(mk_local v_nativearray pos, el);
  1013. etype = gen.gclasses.nativearray t;
  1014. epos = pos;
  1015. }
  1016. let ensure_local gen block name e =
  1017. match e.eexpr with
  1018. | TLocal _ -> e
  1019. | _ ->
  1020. let var = mk_temp gen name e.etype in
  1021. block := { e with eexpr = TVar(var, Some e); etype = gen.gcon.basic.tvoid; } :: !block;
  1022. { e with eexpr = TLocal var }
  1023. let follow_module follow_func md = match md with
  1024. | TClassDecl _
  1025. | TEnumDecl _
  1026. | TAbstractDecl _ -> md
  1027. | TTypeDecl tdecl -> match (follow_func (TType(tdecl, List.map snd tdecl.t_params))) with
  1028. | TInst(cl,_) -> TClassDecl cl
  1029. | TEnum(e,_) -> TEnumDecl e
  1030. | TType(t,_) -> TTypeDecl t
  1031. | TAbstract(a,_) -> TAbstractDecl a
  1032. | _ -> assert false
  1033. (*
  1034. hxgen means if the type was generated by haxe. If a type was generated by haxe, it means
  1035. it will contain special constructs for speedy reflection, for example
  1036. @see SetHXGen module
  1037. *)
  1038. let rec is_hxgen md =
  1039. match md with
  1040. | TClassDecl cl -> Meta.has Meta.HxGen cl.cl_meta
  1041. | TEnumDecl e -> Meta.has Meta.HxGen e.e_meta
  1042. | TTypeDecl t -> Meta.has Meta.HxGen t.t_meta || ( match follow t.t_type with | TInst(cl,_) -> is_hxgen (TClassDecl cl) | TEnum(e,_) -> is_hxgen (TEnumDecl e) | _ -> false )
  1043. | TAbstractDecl a -> Meta.has Meta.HxGen a.a_meta
  1044. let is_hxgen_t t =
  1045. match t with
  1046. | TInst (cl, _) -> Meta.has Meta.HxGen cl.cl_meta
  1047. | TEnum (e, _) -> Meta.has Meta.HxGen e.e_meta
  1048. | TAbstract (a, _) -> Meta.has Meta.HxGen a.a_meta
  1049. | TType (t, _) -> Meta.has Meta.HxGen t.t_meta
  1050. | _ -> false
  1051. let mt_to_t_dyn md =
  1052. match md with
  1053. | TClassDecl cl -> TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_params)
  1054. | TEnumDecl e -> TEnum(e, List.map (fun _ -> t_dynamic) e.e_params)
  1055. | TAbstractDecl a -> TAbstract(a, List.map (fun _ -> t_dynamic) a.a_params)
  1056. | TTypeDecl t -> TType(t, List.map (fun _ -> t_dynamic) t.t_params)
  1057. let mt_to_t mt params =
  1058. match mt with
  1059. | TClassDecl (cl) -> TInst(cl, params)
  1060. | TEnumDecl (e) -> TEnum(e, params)
  1061. | TAbstractDecl a -> TAbstract(a, params)
  1062. | _ -> assert false
  1063. let t_to_mt t =
  1064. match follow t with
  1065. | TInst(cl, _) -> TClassDecl(cl)
  1066. | TEnum(e, _) -> TEnumDecl(e)
  1067. | TAbstract(a, _) -> TAbstractDecl a
  1068. | _ -> assert false
  1069. let rec get_last_ctor cl =
  1070. Option.map_default (fun (super,_) -> if is_some super.cl_constructor then Some(get super.cl_constructor) else get_last_ctor super) None cl.cl_super
  1071. let add_constructor cl cf =
  1072. match cl.cl_constructor with
  1073. | None -> cl.cl_constructor <- Some cf
  1074. | Some ctor ->
  1075. if ctor != cf && not (List.memq cf ctor.cf_overloads) then
  1076. ctor.cf_overloads <- cf :: ctor.cf_overloads
  1077. (* replace open TMonos with TDynamic *)
  1078. let rec replace_mono t =
  1079. match t with
  1080. | TMono t ->
  1081. (match !t with
  1082. | None -> t := Some t_dynamic
  1083. | Some _ -> ())
  1084. | TEnum (_,p) | TInst (_,p) | TType (_,p) | TAbstract (_,p) ->
  1085. List.iter replace_mono p
  1086. | TFun (args,ret) ->
  1087. List.iter (fun (_,_,t) -> replace_mono t) args;
  1088. replace_mono ret
  1089. | TAnon _
  1090. | TDynamic _ -> ()
  1091. | TLazy f ->
  1092. replace_mono (!f())
  1093. (* helper *)
  1094. let mk_class_field name t public pos kind params =
  1095. {
  1096. cf_name = name;
  1097. cf_type = t;
  1098. cf_public = public;
  1099. cf_pos = pos;
  1100. cf_doc = None;
  1101. cf_meta = [ Meta.CompilerGenerated, [], Ast.null_pos ]; (* annotate that this class field was generated by the compiler *)
  1102. cf_kind = kind;
  1103. cf_params = params;
  1104. cf_expr = None;
  1105. cf_overloads = [];
  1106. }
  1107. (* this helper just duplicates the type parameter class, which is assumed that cl is. *)
  1108. (* This is so we can use class parameters on function parameters, without running the risk of name clash *)
  1109. (* between both *)
  1110. let map_param cl =
  1111. let ret = mk_class cl.cl_module (fst cl.cl_path, snd cl.cl_path ^ "_c") cl.cl_pos in
  1112. ret.cl_implements <- cl.cl_implements;
  1113. ret.cl_kind <- cl.cl_kind;
  1114. ret
  1115. let get_cl_t t =
  1116. match follow t with | TInst (cl,_) -> cl | _ -> assert false
  1117. let mk_class m path pos =
  1118. let cl = Type.mk_class m path pos in
  1119. cl.cl_meta <- [ Meta.CompilerGenerated, [], Ast.null_pos ];
  1120. cl
  1121. type tfield_access =
  1122. | FClassField of tclass * tparams * tclass (* declared class *) * tclass_field * bool (* is static? *) * t (* the actual cf type, in relation to the class type params *) * t (* declared type *)
  1123. | FEnumField of tenum * tenum_field * bool (* is parameterized enum ? *)
  1124. | FAnonField of tclass_field
  1125. | FDynamicField of t
  1126. | FNotFound
  1127. let is_var f = match f.cf_kind with | Var _ -> true | _ -> false
  1128. let find_first_declared_field gen orig_cl ?get_vmtype ?exact_field field =
  1129. let get_vmtype = match get_vmtype with None -> (fun t -> t) | Some f -> f in
  1130. let chosen = ref None in
  1131. let is_overload = ref false in
  1132. let rec loop_cl depth c tl tlch =
  1133. (try
  1134. let ret = PMap.find field c.cl_fields in
  1135. if Meta.has Meta.Overload ret.cf_meta then is_overload := true;
  1136. match !chosen, exact_field with
  1137. | Some(d,f,_,_,_), _ when depth <= d || (is_var ret && not (is_var f)) -> ()
  1138. | _, None ->
  1139. chosen := Some(depth,ret,c,tl,tlch)
  1140. | _, Some f2 ->
  1141. List.iter (fun f ->
  1142. let declared_t = apply_params c.cl_params tl f.cf_type in
  1143. if Typeload.same_overload_args ~get_vmtype declared_t f2.cf_type f f2 then
  1144. chosen := Some(depth,f,c,tl,tlch)
  1145. ) (ret :: ret.cf_overloads)
  1146. with | Not_found -> ());
  1147. (match c.cl_super with
  1148. | Some (sup,stl) ->
  1149. let tl = List.map (apply_params c.cl_params tl) stl in
  1150. let stl = gen.greal_type_param (TClassDecl sup) stl in
  1151. let tlch = List.map (apply_params c.cl_params tlch) stl in
  1152. loop_cl (depth+1) sup tl tlch
  1153. | None -> ());
  1154. if c.cl_interface then
  1155. List.iter (fun (sup,stl) ->
  1156. let tl = List.map (apply_params c.cl_params tl) stl in
  1157. let stl = gen.greal_type_param (TClassDecl sup) stl in
  1158. let tlch = List.map (apply_params c.cl_params tlch) stl in
  1159. loop_cl (depth+1) sup tl tlch
  1160. ) c.cl_implements
  1161. in
  1162. loop_cl 0 orig_cl (List.map snd orig_cl.cl_params) (List.map snd orig_cl.cl_params);
  1163. match !chosen with
  1164. | None -> None
  1165. | Some(_,f,c,tl,tlch) ->
  1166. if !is_overload && not (Meta.has Meta.Overload f.cf_meta) then
  1167. f.cf_meta <- (Meta.Overload,[],f.cf_pos) :: f.cf_meta;
  1168. let declared_t = apply_params c.cl_params tl f.cf_type in
  1169. let params_t = apply_params c.cl_params tlch f.cf_type in
  1170. let actual_t = match follow params_t with
  1171. | TFun(args,ret) -> TFun(List.map (fun (n,o,t) -> (n,o,gen.greal_type t)) args, gen.greal_type ret)
  1172. | _ -> gen.greal_type params_t in
  1173. Some(f,actual_t,declared_t,params_t,c,tl,tlch)
  1174. let field_access gen (t:t) (field:string) : (tfield_access) =
  1175. (*
  1176. t can be either an haxe-type as a real-type;
  1177. 'follow' should be applied here since we can generalize that a TType will be accessible as its
  1178. underlying type.
  1179. *)
  1180. (* let pointers to values be accessed as the underlying values *)
  1181. let t = match gen.greal_type t with
  1182. | TAbstract({ a_path = ["cs"],"Pointer" },[t]) ->
  1183. gen.greal_type t
  1184. | _ -> t
  1185. in
  1186. match follow t with
  1187. | TInst(cl, params) ->
  1188. let orig_cl = cl in
  1189. let orig_params = params in
  1190. let rec not_found cl params =
  1191. match cl.cl_dynamic with
  1192. | Some t ->
  1193. let t = apply_params cl.cl_params params t in
  1194. FDynamicField t
  1195. | None ->
  1196. match cl.cl_super with
  1197. | None -> FNotFound
  1198. | Some (super,p) -> not_found super p
  1199. in
  1200. let not_found () =
  1201. try
  1202. let cf = PMap.find field gen.gbase_class_fields in
  1203. FClassField (orig_cl, orig_params, gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type)
  1204. with
  1205. | Not_found -> not_found cl params
  1206. in
  1207. (* this is a hack for C#'s different generic types with same path *)
  1208. let hashtbl_field = (String.concat "" (List.map (fun _ -> "]") cl.cl_params)) ^ field in
  1209. let types = try
  1210. Hashtbl.find gen.greal_field_types (orig_cl.cl_path, hashtbl_field)
  1211. with | Not_found ->
  1212. let ret = find_first_declared_field gen cl field in
  1213. let ret = match ret with
  1214. | None -> None
  1215. | Some(cf,t,dt,_,cl,_,_) -> Some(cf,t,dt,cl)
  1216. in
  1217. if ret <> None then Hashtbl.add gen.greal_field_types (orig_cl.cl_path, hashtbl_field) ret;
  1218. ret
  1219. in
  1220. (match types with
  1221. | None -> not_found()
  1222. | Some (cf, actual_t, declared_t, declared_cl) ->
  1223. FClassField(orig_cl, orig_params, declared_cl, cf, false, actual_t, declared_t))
  1224. | TEnum _ | TAbstract _ ->
  1225. (* enums have no field *) FNotFound
  1226. | TAnon anon ->
  1227. (try match !(anon.a_status) with
  1228. | Statics cl ->
  1229. let cf = PMap.find field cl.cl_statics in
  1230. FClassField(cl, List.map (fun _ -> t_dynamic) cl.cl_params, cl, cf, true, cf.cf_type, cf.cf_type)
  1231. | EnumStatics e ->
  1232. let f = PMap.find field e.e_constrs in
  1233. let is_param = match follow f.ef_type with | TFun _ -> true | _ -> false in
  1234. FEnumField(e, f, is_param)
  1235. | _ when PMap.mem field gen.gbase_class_fields ->
  1236. let cf = PMap.find field gen.gbase_class_fields in
  1237. FClassField(gen.gclasses.cl_dyn, [t_dynamic], gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type)
  1238. | _ ->
  1239. FAnonField(PMap.find field anon.a_fields)
  1240. with | Not_found -> FNotFound)
  1241. | _ when PMap.mem field gen.gbase_class_fields ->
  1242. let cf = PMap.find field gen.gbase_class_fields in
  1243. FClassField(gen.gclasses.cl_dyn, [t_dynamic], gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type)
  1244. | TDynamic t -> FDynamicField t
  1245. | TMono _ -> FDynamicField t_dynamic
  1246. | _ -> FNotFound
  1247. let field_access_esp gen t field = match field with
  1248. | FStatic(cl,cf) | FInstance(cl,_,cf) when Meta.has Meta.Extern cf.cf_meta ->
  1249. let static = match field with
  1250. | FStatic _ -> true
  1251. | _ -> false
  1252. in
  1253. let p = match follow (run_follow gen t) with
  1254. | TInst(_,p) -> p
  1255. | _ -> List.map snd cl.cl_params
  1256. in
  1257. FClassField(cl,p,cl,cf,static,cf.cf_type,cf.cf_type)
  1258. | _ -> field_access gen t (field_name field)
  1259. let mk_field_access gen expr field pos =
  1260. match field_access gen expr.etype field with
  1261. | FClassField(c,p,dc,cf,false,at,_) ->
  1262. { eexpr = TField(expr, FInstance(dc,p,cf)); etype = apply_params c.cl_params p at; epos = pos }
  1263. | FClassField(c,p,dc,cf,true,at,_) ->
  1264. { eexpr = TField(expr, FStatic(dc,cf)); etype = at; epos = pos }
  1265. | FAnonField cf ->
  1266. { eexpr = TField(expr, FAnon cf); etype = cf.cf_type; epos = pos }
  1267. | FDynamicField t ->
  1268. { eexpr = TField(expr, FDynamic field); etype = t; epos = pos }
  1269. | FNotFound ->
  1270. { eexpr = TField(expr, FDynamic field); etype = t_dynamic; epos = pos }
  1271. | FEnumField _ -> assert false
  1272. let mk_iterator_access gen t expr =
  1273. let pos = expr.epos in
  1274. let itf = mk_field_access gen expr "iterator" pos in
  1275. { eexpr = TCall(itf, []); epos = pos; etype = snd (get_fun itf.etype) }
  1276. (* ******************************************* *)
  1277. (* Module dependency resolution *)
  1278. (* ******************************************* *)
  1279. type t_dependency =
  1280. | DAfter of float
  1281. | DBefore of float
  1282. exception ImpossibleDependency of string
  1283. let max_dep = 10000.0
  1284. let min_dep = - (10000.0)
  1285. let solve_deps name (deps:t_dependency list) =
  1286. let vmin = min_dep -. 1.0 in
  1287. let vmax = max_dep +. 1.0 in
  1288. let rec loop dep vmin vmax =
  1289. match dep with
  1290. | [] ->
  1291. (if vmin >= vmax then raise (ImpossibleDependency name));
  1292. (vmin +. vmax) /. 2.0
  1293. | head :: tail ->
  1294. match head with
  1295. | DBefore f ->
  1296. loop tail (max vmin f) vmax
  1297. | DAfter f ->
  1298. loop tail vmin (min vmax f)
  1299. in
  1300. loop deps vmin vmax
  1301. (* type resolution *)
  1302. exception TypeNotFound of path
  1303. let get_type gen path =
  1304. try Hashtbl.find gen.gtypes path with | Not_found -> raise (TypeNotFound path)
  1305. (* ******************************************* *)
  1306. (* follow all module *)
  1307. (* ******************************************* *)
  1308. (*
  1309. this module will follow each and every type using the rules defined in
  1310. gen.gfollow. This is a minor helper module, so we don't end up
  1311. having to follow the same time multiple times in the many filter iterations
  1312. because of this, it will be one of the first modules to run.
  1313. *)
  1314. module FollowAll =
  1315. struct
  1316. let follow gen e =
  1317. let follow_func = gen.gfollow#run_f in
  1318. Some (Type.map_expr_type (fun e->e) (follow_func) (fun tvar-> tvar.v_type <- (follow_func tvar.v_type); tvar) e)
  1319. let priority = max_dep
  1320. (* will add an expression filter as the first filter *)
  1321. let configure gen =
  1322. gen.gexpr_filters#add ~name:"follow_all" ~priority:(PCustom(priority)) (follow gen)
  1323. end;;
  1324. (* ******************************************* *)
  1325. (* set hxgen module *)
  1326. (* ******************************************* *)
  1327. (*
  1328. goes through all module types and sets the :hxgen meta on all which
  1329. then is_hxgen_func returns true. There is a default is_hxgen_func implementation also
  1330. *)
  1331. module SetHXGen =
  1332. struct
  1333. (*
  1334. basically, everything that is extern is assumed to not be hxgen, unless meta :hxgen is set, and
  1335. everything that is not extern is assumed to be hxgen, unless meta :nativegen is set
  1336. *)
  1337. let rec default_hxgen_func gen md =
  1338. match md with
  1339. | TClassDecl { cl_kind = KAbstractImpl a } ->
  1340. default_hxgen_func gen (TAbstractDecl a)
  1341. | TClassDecl cl ->
  1342. let rec is_hxgen_class (c,_) =
  1343. if c.cl_extern then begin
  1344. if Meta.has Meta.HxGen c.cl_meta then true else Option.map_default (is_hxgen_class) false c.cl_super || List.exists is_hxgen_class c.cl_implements
  1345. end else begin
  1346. if Meta.has Meta.NativeChildren c.cl_meta || Meta.has Meta.NativeGen c.cl_meta then
  1347. Option.map_default (is_hxgen_class) false c.cl_super || List.exists is_hxgen_class c.cl_implements
  1348. else
  1349. let rec has_nativec (c,p) =
  1350. if is_hxgen_class (c,p) then
  1351. false
  1352. else
  1353. (Meta.has Meta.NativeChildren c.cl_meta && not (Option.map_default is_hxgen_class false c.cl_super || List.exists is_hxgen_class c.cl_implements))
  1354. || Option.map_default has_nativec false c.cl_super
  1355. in
  1356. if Option.map_default has_nativec false c.cl_super && not (List.exists is_hxgen_class c.cl_implements) then
  1357. false
  1358. else
  1359. true
  1360. end
  1361. in
  1362. is_hxgen_class (cl,[])
  1363. | TEnumDecl e -> if e.e_extern then Meta.has Meta.HxGen e.e_meta else
  1364. if Meta.has Meta.NativeGen e.e_meta then
  1365. if Meta.has Meta.FlatEnum e.e_meta then
  1366. false
  1367. else begin
  1368. gen.gcon.error "Only flat enums may be @:nativeGen" e.e_pos;
  1369. true
  1370. end
  1371. else
  1372. true
  1373. (* not (Meta.has Meta.NativeGen e.e_meta) *)
  1374. | TAbstractDecl a when Meta.has Meta.CoreType a.a_meta -> not (Meta.has Meta.NativeGen a.a_meta)
  1375. | TAbstractDecl a -> (match follow a.a_this with
  1376. | TInst _ | TEnum _ | TAbstract _ ->
  1377. default_hxgen_func gen (t_to_md (follow a.a_this))
  1378. | _ ->
  1379. not (Meta.has Meta.NativeGen a.a_meta))
  1380. | TTypeDecl t -> (* TODO see when would we use this *)
  1381. false
  1382. (*
  1383. by now the only option is to run it eagerly, because it must be one of the first filters to run,
  1384. since many others depend of it
  1385. *)
  1386. let run_filter gen is_hxgen_func =
  1387. let filter md =
  1388. let meta = if is_hxgen_func gen md then Meta.HxGen else Meta.NativeGen in
  1389. begin
  1390. match md with
  1391. | TClassDecl cl -> cl.cl_meta <- (meta, [], cl.cl_pos) :: cl.cl_meta
  1392. | TEnumDecl e -> e.e_meta <- (meta, [], e.e_pos) :: e.e_meta
  1393. | TTypeDecl t -> t.t_meta <- (meta, [], t.t_pos) :: t.t_meta
  1394. | TAbstractDecl a -> a.a_meta <- (meta, [], a.a_pos) :: a.a_meta
  1395. end
  1396. in
  1397. List.iter filter gen.gtypes_list
  1398. end;;
  1399. (* ******************************************* *)
  1400. (* overloading reflection constructors *)
  1401. (* ******************************************* *)
  1402. (*
  1403. this module works on languages that support function overloading and
  1404. enable function hiding via static functions.
  1405. it takes the constructor body out of the constructor and adds it to a special ctor
  1406. static function. The static function will receive the same parameters as the constructor,
  1407. plus the special "me" var, which will replace "this"
  1408. Then it always adds two constructors to the function: one that receives a special class,
  1409. indicating that it should be constructed without any parameters, and one that receives its normal constructor.
  1410. Both will only include a super() call to the superclasses' emtpy constructor.
  1411. This enables two things:
  1412. empty construction without the need of incompatibility with the platform's native construction method
  1413. the ability to call super() constructor in any place in the constructor
  1414. This will insert itself in the default reflection-related module filter
  1415. *)
  1416. module OverloadingConstructor =
  1417. struct
  1418. let priority = 0.0
  1419. let name = "overloading_constructor"
  1420. let set_new_create_empty gen empty_ctor_expr =
  1421. let old = gen.gtools.rf_create_empty in
  1422. gen.gtools.rf_create_empty <- (fun cl params pos ->
  1423. if is_hxgen (TClassDecl cl) then
  1424. { eexpr = TNew(cl,params,[empty_ctor_expr]); etype = TInst(cl,params); epos = pos }
  1425. else
  1426. old cl params pos
  1427. )
  1428. let rec cur_ctor c tl =
  1429. match c.cl_constructor with
  1430. | Some ctor -> ctor, c, tl
  1431. | None -> match c.cl_super with
  1432. | None -> raise Not_found
  1433. | Some (sup,stl) ->
  1434. cur_ctor sup (List.map (apply_params c.cl_params tl) stl)
  1435. let rec prev_ctor c tl =
  1436. match c.cl_super with
  1437. | None -> raise Not_found
  1438. | Some (sup,stl) ->
  1439. let stl = List.map (apply_params c.cl_params tl) stl in
  1440. match sup.cl_constructor with
  1441. | None -> prev_ctor sup stl
  1442. | Some ctor -> ctor, sup, stl
  1443. (* replaces super() call with last static constructor call *)
  1444. let replace_super_call gen name c tl with_params me p =
  1445. let rec loop_super c tl = match c.cl_super with
  1446. | None -> raise Not_found
  1447. | Some(sup,stl) ->
  1448. let stl = List.map (apply_params c.cl_params tl) stl in
  1449. try
  1450. let static_ctor_name = name ^ "_" ^ (String.concat "_" (fst sup.cl_path)) ^ "_" ^ (snd sup.cl_path) in
  1451. sup, stl, PMap.find static_ctor_name sup.cl_statics
  1452. with | Not_found ->
  1453. loop_super sup stl
  1454. in
  1455. let sup, stl, cf = loop_super c tl in
  1456. let with_params = { eexpr = TLocal me; etype = me.v_type; epos = p } :: with_params in
  1457. let cf = match cf.cf_overloads with
  1458. (* | [] -> cf *)
  1459. | _ -> try
  1460. (* choose best super function *)
  1461. List.iter (fun e -> replace_mono e.etype) with_params;
  1462. List.find (fun cf ->
  1463. replace_mono cf.cf_type;
  1464. let args, _ = get_fun (apply_params cf.cf_params stl cf.cf_type) in
  1465. try
  1466. List.for_all2 (fun (_,_,t) e -> try
  1467. let e_etype = run_follow gen e.etype in
  1468. let t = run_follow gen t in
  1469. unify e_etype t; true
  1470. with | Unify_error _ -> false) args with_params
  1471. with | Invalid_argument("List.for_all2") -> false
  1472. ) (cf :: cf.cf_overloads)
  1473. with | Not_found ->
  1474. gen.gcon.error "No suitable overload for the super call arguments was found" p; cf
  1475. in
  1476. {
  1477. eexpr = TCall({
  1478. eexpr = TField(
  1479. mk_classtype_access sup p,
  1480. FStatic(sup,cf));
  1481. etype = apply_params cf.cf_params stl cf.cf_type;
  1482. epos = p},
  1483. with_params);
  1484. etype = gen.gcon.basic.tvoid;
  1485. epos = p;
  1486. }
  1487. (* will create a static counterpart of 'ctor', and replace its contents to a call to the static version*)
  1488. let create_static_ctor gen ~empty_ctor_expr cl name ctor =
  1489. match Meta.has Meta.SkipCtor ctor.cf_meta with
  1490. | true -> ()
  1491. | false when is_none ctor.cf_expr -> ()
  1492. | false ->
  1493. let static_ctor_name = name ^ "_" ^ (String.concat "_" (fst cl.cl_path)) ^ "_" ^ (snd cl.cl_path) in
  1494. (* create the static constructor *)
  1495. let basic = gen.gcon.basic in
  1496. let ctor_types = List.map (fun (s,t) -> (s, TInst(map_param (get_cl_t t), []))) cl.cl_params in
  1497. let me = mk_temp gen "me" (TInst(cl, List.map snd ctor_types)) in
  1498. me.v_capture <- true;
  1499. let fn_args, _ = get_fun ctor.cf_type in
  1500. let ctor_params = List.map snd ctor_types in
  1501. let fn_type = TFun((me.v_name,false, me.v_type) :: List.map (fun (n,o,t) -> (n,o,apply_params cl.cl_params ctor_params t)) fn_args, basic.tvoid) in
  1502. let cur_tf_args = match ctor.cf_expr with
  1503. | Some { eexpr = TFunction(tf) } -> tf.tf_args
  1504. | _ -> assert false
  1505. in
  1506. let changed_tf_args = List.map (fun (v,_) -> (v,None)) cur_tf_args in
  1507. let local_map = Hashtbl.create (List.length cur_tf_args) in
  1508. let static_tf_args = (me, None) :: List.map (fun (v,b) ->
  1509. let new_v = alloc_var v.v_name (apply_params cl.cl_params ctor_params v.v_type) in
  1510. new_v.v_capture <- v.v_capture;
  1511. Hashtbl.add local_map v.v_id new_v;
  1512. (new_v, b)
  1513. ) cur_tf_args in
  1514. let static_ctor = mk_class_field static_ctor_name fn_type false ctor.cf_pos (Method MethNormal) ctor_types in
  1515. (* change ctor contents to reference the 'me' var instead of 'this' *)
  1516. let actual_super_call = ref None in
  1517. let rec map_expr ~is_first e = match e.eexpr with
  1518. | TCall (({ eexpr = TConst TSuper } as tsuper), params) -> (try
  1519. let params = List.map (fun e -> map_expr ~is_first:false e) params in
  1520. actual_super_call := Some { e with eexpr = TCall(tsuper, [empty_ctor_expr]) };
  1521. replace_super_call gen name cl ctor_params params me e.epos
  1522. with | Not_found ->
  1523. (* last static function was not found *)
  1524. actual_super_call := Some e;
  1525. if not is_first then
  1526. gen.gcon.error "Super call must be the first call when extending native types" e.epos;
  1527. { e with eexpr = TBlock([]) })
  1528. | TFunction tf when is_first ->
  1529. do_map ~is_first:true e
  1530. | TConst TThis ->
  1531. mk_local me e.epos
  1532. | TBlock (fst :: bl) ->
  1533. let fst = map_expr ~is_first:is_first fst in
  1534. { e with eexpr = TBlock(fst :: List.map (fun e -> map_expr ~is_first:false e) bl); etype = apply_params cl.cl_params ctor_params e.etype }
  1535. | _ ->
  1536. do_map e
  1537. and do_map ?(is_first=false) e =
  1538. let do_t = apply_params cl.cl_params ctor_params in
  1539. let do_v v = try
  1540. Hashtbl.find local_map v.v_id
  1541. with | Not_found ->
  1542. v.v_type <- do_t v.v_type; v
  1543. in
  1544. Type.map_expr_type (map_expr ~is_first:is_first) do_t do_v e
  1545. in
  1546. let expr = do_map ~is_first:true (get ctor.cf_expr) in
  1547. let expr = match expr.eexpr with
  1548. | TFunction(tf) ->
  1549. { expr with etype = fn_type; eexpr = TFunction({ tf with tf_args = static_tf_args }) }
  1550. | _ -> assert false in
  1551. static_ctor.cf_expr <- Some expr;
  1552. (* add to the statics *)
  1553. (try
  1554. let stat = PMap.find static_ctor_name cl.cl_statics in
  1555. stat.cf_overloads <- static_ctor :: stat.cf_overloads
  1556. with | Not_found ->
  1557. cl.cl_ordered_statics <- static_ctor :: cl.cl_ordered_statics;
  1558. cl.cl_statics <- PMap.add static_ctor_name static_ctor cl.cl_statics);
  1559. (* change current super call *)
  1560. match ctor.cf_expr with
  1561. | Some({ eexpr = TFunction(tf) } as e) ->
  1562. let block_contents, p = match !actual_super_call with
  1563. | None -> [], ctor.cf_pos
  1564. | Some super -> [super], super.epos
  1565. in
  1566. let block_contents = block_contents @ [{
  1567. eexpr = TCall(
  1568. {
  1569. eexpr = TField(
  1570. mk_classtype_access cl p,
  1571. FStatic(cl, static_ctor));
  1572. etype = apply_params static_ctor.cf_params (List.map snd cl.cl_params) static_ctor.cf_type;
  1573. epos = p
  1574. },
  1575. [{ eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_params); epos = p }]
  1576. @ List.map (fun (v,_) -> mk_local v p) cur_tf_args
  1577. );
  1578. etype = basic.tvoid;
  1579. epos = p
  1580. }] in
  1581. ctor.cf_expr <- Some { e with eexpr = TFunction({ tf with tf_expr = { tf.tf_expr with eexpr = TBlock block_contents }; tf_args = changed_tf_args }) }
  1582. | _ -> assert false
  1583. (* makes constructors that only call super() for the 'ctor' argument *)
  1584. let clone_ctors gen ctor sup stl cl =
  1585. let basic = gen.gcon.basic in
  1586. let rec clone cf =
  1587. let ncf = mk_class_field "new" (apply_params sup.cl_params stl cf.cf_type) cf.cf_public cf.cf_pos cf.cf_kind cf.cf_params in
  1588. let args, ret = get_fun ncf.cf_type in
  1589. (* single expression: call to super() *)
  1590. let tf_args = List.map (fun (name,_,t) ->
  1591. (* the constructor will have no optional arguments, as presumably this will be handled by the underlying expr *)
  1592. alloc_var name t, None
  1593. ) args in
  1594. let super_call =
  1595. {
  1596. eexpr = TCall(
  1597. { eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_params); epos = ctor.cf_pos },
  1598. List.map (fun (v,_) -> mk_local v ctor.cf_pos) tf_args);
  1599. etype = basic.tvoid;
  1600. epos = ctor.cf_pos;
  1601. } in
  1602. ncf.cf_expr <- Some
  1603. {
  1604. eexpr = TFunction {
  1605. tf_args = tf_args;
  1606. tf_type = basic.tvoid;
  1607. tf_expr = mk_block super_call;
  1608. };
  1609. etype = ncf.cf_type;
  1610. epos = ctor.cf_pos;
  1611. };
  1612. ncf
  1613. in
  1614. (* take off createEmpty *)
  1615. let all = List.filter (fun cf -> replace_mono cf.cf_type; not (Meta.has Meta.SkipCtor cf.cf_meta)) (ctor :: ctor.cf_overloads) in
  1616. let clones = List.map clone all in
  1617. match clones with
  1618. | [] ->
  1619. (* raise Not_found *)
  1620. assert false (* should never happen *)
  1621. | cf :: [] -> cf
  1622. | cf :: overl ->
  1623. cf.cf_meta <- (Meta.Overload,[],cf.cf_pos) :: cf.cf_meta;
  1624. cf.cf_overloads <- overl; cf
  1625. let rec descends_from_native_or_skipctor cl =
  1626. not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta || match cl.cl_super with
  1627. | None -> false
  1628. | Some(c,_) -> descends_from_native_or_skipctor c
  1629. let ensure_super_is_first gen cf =
  1630. let rec loop e =
  1631. match e.eexpr with
  1632. | TBlock (b :: block) ->
  1633. loop b
  1634. | TBlock []
  1635. | TCall({ eexpr = TConst TSuper },_) -> ()
  1636. | _ ->
  1637. gen.gcon.error "Types that derive from a native class must have its super() call as the first statement in the constructor" cf.cf_pos
  1638. in
  1639. match cf.cf_expr with
  1640. | None -> ()
  1641. | Some e -> Type.iter loop e
  1642. (* major restructring made at r6493 *)
  1643. let configure ~(empty_ctor_type : t) ~(empty_ctor_expr : texpr) ~supports_ctor_inheritance gen =
  1644. set_new_create_empty gen empty_ctor_expr;
  1645. let basic = gen.gcon.basic in
  1646. let should_change cl = not cl.cl_interface && (not cl.cl_extern || is_hxgen (TClassDecl cl)) && (match cl.cl_kind with KAbstractImpl _ -> false | _ -> true) in
  1647. let static_ctor_name = gen.gmk_internal_name "hx" "ctor" in
  1648. let msize = List.length gen.gtypes_list in
  1649. let processed, empty_ctors = Hashtbl.create msize, Hashtbl.create msize in
  1650. let rec get_last_empty cl =
  1651. try
  1652. Hashtbl.find empty_ctors cl.cl_path
  1653. with | Not_found ->
  1654. match cl.cl_super with
  1655. | None -> raise Not_found
  1656. | Some (sup,_) -> get_last_empty sup
  1657. in
  1658. let rec change cl =
  1659. match Hashtbl.mem processed cl.cl_path with
  1660. | true -> ()
  1661. | false ->
  1662. Hashtbl.add processed cl.cl_path true;
  1663. (* make sure we've processed the super types *)
  1664. (match cl.cl_super with
  1665. | Some (super,_) when should_change super && not (Hashtbl.mem processed super.cl_path) ->
  1666. change super
  1667. | _ -> ());
  1668. (* implement static hx_ctor and reimplement constructors *)
  1669. (try
  1670. let ctor = match cl.cl_constructor with
  1671. | Some ctor -> ctor
  1672. | None -> try
  1673. let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_params) in
  1674. (* we have a previous constructor. if we support inheritance, exit *)
  1675. if supports_ctor_inheritance then raise Exit;
  1676. (* we'll make constructors that will only call super() *)
  1677. let ctor = clone_ctors gen sctor sup stl cl in
  1678. cl.cl_constructor <- Some ctor;
  1679. ctor
  1680. with | Not_found -> (* create default constructor *)
  1681. let ctor = mk_class_field "new" (TFun([], basic.tvoid)) false cl.cl_pos (Method MethNormal) [] in
  1682. ctor.cf_expr <- Some
  1683. {
  1684. eexpr = TFunction {
  1685. tf_args = [];
  1686. tf_type = basic.tvoid;
  1687. tf_expr = { eexpr = TBlock[]; etype = basic.tvoid; epos = cl.cl_pos };
  1688. };
  1689. etype = ctor.cf_type;
  1690. epos = ctor.cf_pos;
  1691. };
  1692. cl.cl_constructor <- Some ctor;
  1693. ctor
  1694. in
  1695. (* now that we made sure we have a constructor, exit if native gen *)
  1696. if not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta then begin
  1697. if descends_from_native_or_skipctor cl && is_some cl.cl_super then
  1698. List.iter (fun cf -> ensure_super_is_first gen cf) (ctor :: ctor.cf_overloads);
  1699. raise Exit
  1700. end;
  1701. (* if cl descends from a native class, we cannot use the static constructor strategy *)
  1702. if descends_from_native_or_skipctor cl && is_some cl.cl_super then
  1703. List.iter (fun cf -> ensure_super_is_first gen cf) (ctor :: ctor.cf_overloads)
  1704. else
  1705. (* now that we have a current ctor, create the static counterparts *)
  1706. List.iter (fun cf ->
  1707. create_static_ctor gen ~empty_ctor_expr:empty_ctor_expr cl static_ctor_name cf
  1708. ) (ctor :: ctor.cf_overloads)
  1709. with | Exit ->());
  1710. (* implement empty ctor *)
  1711. (try
  1712. (* now that we made sure we have a constructor, exit if native gen *)
  1713. if not (is_hxgen (TClassDecl cl)) then raise Exit;
  1714. (* get first *)
  1715. let empty_type = TFun(["empty",false,empty_ctor_type],basic.tvoid) in
  1716. let super = match cl.cl_super with
  1717. | None -> (* implement empty *)
  1718. []
  1719. | Some (sup,_) -> try
  1720. ignore (get_last_empty sup);
  1721. if supports_ctor_inheritance && is_none cl.cl_constructor then raise Exit;
  1722. [{
  1723. eexpr = TCall(
  1724. { eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_params); epos = cl.cl_pos },
  1725. [ empty_ctor_expr ]);
  1726. etype = basic.tvoid;
  1727. epos = cl.cl_pos
  1728. }]
  1729. with | Not_found -> try
  1730. (* super type is native: find super constructor with least arguments *)
  1731. let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_params) in
  1732. let rec loop remaining (best,n) =
  1733. match remaining with
  1734. | [] -> best
  1735. | cf :: r ->
  1736. let args,_ = get_fun cf.cf_type in
  1737. if (List.length args) < n then
  1738. loop r (cf,List.length args)
  1739. else
  1740. loop r (best,n)
  1741. in
  1742. let args,_ = get_fun sctor.cf_type in
  1743. let best = loop sctor.cf_overloads (sctor, List.length args) in
  1744. let args,_ = get_fun (apply_params sup.cl_params stl best.cf_type) in
  1745. [{
  1746. eexpr = TCall(
  1747. { eexpr = TConst TSuper; etype = TInst(sup, stl); epos = cl.cl_pos },
  1748. List.map (fun (n,o,t) -> null t cl.cl_pos) args);
  1749. etype = basic.tvoid;
  1750. epos = cl.cl_pos
  1751. }]
  1752. with | Not_found ->
  1753. (* extends native type, but no ctor found *)
  1754. []
  1755. in
  1756. let ctor = mk_class_field "new" empty_type false cl.cl_pos (Method MethNormal) [] in
  1757. ctor.cf_expr <- Some {
  1758. eexpr = TFunction {
  1759. tf_type = basic.tvoid;
  1760. tf_args = [alloc_var "empty" empty_ctor_type, None];
  1761. tf_expr = { eexpr = TBlock super; etype = basic.tvoid; epos = cl.cl_pos }
  1762. };
  1763. etype = empty_type;
  1764. epos = cl.cl_pos;
  1765. };
  1766. ctor.cf_meta <- [Meta.SkipCtor, [], ctor.cf_pos];
  1767. Hashtbl.add empty_ctors cl.cl_path ctor;
  1768. match cl.cl_constructor with
  1769. | None -> cl.cl_constructor <- Some ctor
  1770. | Some c -> c.cf_overloads <- ctor :: c.cf_overloads
  1771. with | Exit -> ());
  1772. in
  1773. let module_filter md = match md with
  1774. | TClassDecl cl when should_change cl && not (Hashtbl.mem processed cl.cl_path) ->
  1775. change cl;
  1776. None
  1777. | _ -> None
  1778. in
  1779. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) module_filter
  1780. end;;
  1781. (* ******************************************* *)
  1782. (* init function module *)
  1783. (* ******************************************* *)
  1784. (*
  1785. This module will take proper care of the init function, by taking off all expressions from static vars and putting them
  1786. in order in the init function.
  1787. It will also initialize dynamic functions, both by putting them in the constructor and in the init function
  1788. depends on:
  1789. (syntax) must run before ExprStatement module
  1790. (ok) must run before OverloadingCtor module so the constructor can be in the correct place
  1791. (syntax) must run before FunctionToClass module
  1792. *)
  1793. module InitFunction =
  1794. struct
  1795. let name = "init_funcs"
  1796. let priority = solve_deps name [DBefore OverloadingConstructor.priority]
  1797. let ensure_simple_expr gen e =
  1798. let rec iter e = match e.eexpr with
  1799. | TConst _ | TLocal _ | TArray _ | TBinop _
  1800. | TField _ | TTypeExpr _ | TParenthesis _ | TCast _
  1801. | TCall _ | TNew _ | TUnop _ ->
  1802. Type.iter iter e
  1803. | _ ->
  1804. print_endline (debug_expr e);
  1805. gen.gcon.error "Expression is too complex for a readonly variable initialization" e.epos
  1806. in
  1807. iter e
  1808. let configure gen should_handle_dynamic_functions readonly_support =
  1809. let handle_override_dynfun acc e this field =
  1810. let add_expr = ref None in
  1811. let v = mk_temp gen ("super_" ^ field) e.etype in
  1812. v.v_capture <- true;
  1813. let rec loop e =
  1814. match e.eexpr with
  1815. | TField({ eexpr = TConst(TSuper) }, f) ->
  1816. let n = field_name f in
  1817. (if n <> field then assert false);
  1818. let local = mk_local v e.epos in
  1819. (match !add_expr with
  1820. | None ->
  1821. add_expr := Some { e with eexpr = TVar(v, Some this) }
  1822. | Some _ -> ());
  1823. local
  1824. | TConst TSuper -> assert false
  1825. | _ -> Type.map_expr loop e
  1826. in
  1827. let e = loop e in
  1828. match !add_expr with
  1829. | None -> e :: acc
  1830. | Some add_expr -> add_expr :: e :: acc
  1831. in
  1832. let handle_class cl =
  1833. let init = match cl.cl_init with
  1834. | None -> []
  1835. | Some i -> [i]
  1836. in
  1837. let init = List.fold_left (fun acc cf ->
  1838. match cf.cf_kind, should_handle_dynamic_functions with
  1839. | (Var v, _) when Meta.has Meta.ReadOnly cf.cf_meta && readonly_support ->
  1840. if v.v_write <> AccNever && not (Meta.has Meta.CoreApi cl.cl_meta) then gen.gcon.warning "@:readOnly variable declared without `never` setter modifier" cf.cf_pos;
  1841. (match cf.cf_expr with
  1842. | None -> gen.gcon.warning "Uninitialized readonly variable" cf.cf_pos; acc
  1843. | Some e -> ensure_simple_expr gen e; acc)
  1844. | (Var _, _)
  1845. | (Method (MethDynamic), true) when not (Type.is_extern_field cf) ->
  1846. (match cf.cf_expr with
  1847. | Some e ->
  1848. (match cf.cf_params with
  1849. | [] ->
  1850. let var = { eexpr = TField(mk_classtype_access cl cf.cf_pos, FStatic(cl,cf)); etype = cf.cf_type; epos = cf.cf_pos } in
  1851. let ret = ({ eexpr = TBinop(Ast.OpAssign, var, e); etype = cf.cf_type; epos = cf.cf_pos; }) in
  1852. cf.cf_expr <- None;
  1853. ret :: acc
  1854. | _ ->
  1855. let params = List.map (fun _ -> t_dynamic) cf.cf_params in
  1856. let fn = apply_params cf.cf_params params in
  1857. let var = { eexpr = TField(mk_classtype_access cl cf.cf_pos, FStatic(cl,cf)); etype = fn cf.cf_type; epos = cf.cf_pos } in
  1858. let rec change_expr e =
  1859. Type.map_expr_type (change_expr) fn (fun v -> v.v_type <- fn v.v_type; v) e
  1860. in
  1861. let ret = ({ eexpr = TBinop(Ast.OpAssign, var, change_expr e); etype = fn cf.cf_type; epos = cf.cf_pos; }) in
  1862. cf.cf_expr <- None;
  1863. ret :: acc
  1864. )
  1865. | None -> acc)
  1866. | _ -> acc
  1867. ) init cl.cl_ordered_statics
  1868. in
  1869. let init = List.rev init in
  1870. (match init with
  1871. | [] -> cl.cl_init <- None
  1872. | _ -> cl.cl_init <- Some { eexpr = TBlock(init); epos = cl.cl_pos; etype = gen.gcon.basic.tvoid; });
  1873. (* FIXME: find a way to tell OverloadingCtors to execute this code even with empty constructors *)
  1874. if should_handle_dynamic_functions then begin
  1875. let vars, funs = List.fold_left (fun (acc_vars,acc_funs) cf ->
  1876. match cf.cf_kind with
  1877. | Var v when Meta.has Meta.ReadOnly cf.cf_meta && readonly_support ->
  1878. if v.v_write <> AccNever && not (Meta.has Meta.CoreApi cl.cl_meta) then gen.gcon.warning "@:readOnly variable declared without `never` setter modifier" cf.cf_pos;
  1879. (match cf.cf_expr with
  1880. | None -> (acc_vars,acc_funs)
  1881. | Some e -> ensure_simple_expr gen e; (acc_vars,acc_funs))
  1882. | Var _
  1883. | Method(MethDynamic) ->
  1884. let is_var = match cf.cf_kind with | Var _ -> true | _ -> false in
  1885. (match cf.cf_expr, cf.cf_params with
  1886. | Some e, [] ->
  1887. let var = { eexpr = TField({ eexpr = TConst(TThis); epos = cf.cf_pos; etype = TInst(cl, List.map snd cl.cl_params); }, FInstance(cl, List.map snd cl.cl_params, cf)); etype = cf.cf_type; epos = cf.cf_pos } in
  1888. let ret = ({ eexpr = TBinop(Ast.OpAssign, var, e); etype = cf.cf_type; epos = cf.cf_pos; }) in
  1889. cf.cf_expr <- None;
  1890. let is_override = List.memq cf cl.cl_overrides in
  1891. if is_override then begin
  1892. cl.cl_ordered_fields <- List.filter (fun f -> f.cf_name <> cf.cf_name) cl.cl_ordered_fields;
  1893. cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields;
  1894. acc_vars, handle_override_dynfun acc_funs ret var cf.cf_name
  1895. end else if is_var then
  1896. ret :: acc_vars, acc_funs
  1897. else
  1898. acc_vars, ret :: acc_funs
  1899. | Some e, _ ->
  1900. let params = List.map (fun _ -> t_dynamic) cf.cf_params in
  1901. let fn = apply_params cf.cf_params params in
  1902. let var = { eexpr = TField({ eexpr = TConst(TThis); epos = cf.cf_pos; etype = TInst(cl, List.map snd cl.cl_params); }, FInstance(cl, List.map snd cl.cl_params, cf)); etype = cf.cf_type; epos = cf.cf_pos } in
  1903. let rec change_expr e =
  1904. Type.map_expr_type (change_expr) fn (fun v -> v.v_type <- fn v.v_type; v) e
  1905. in
  1906. let ret = ({ eexpr = TBinop(Ast.OpAssign, var, change_expr e); etype = fn cf.cf_type; epos = cf.cf_pos; }) in
  1907. cf.cf_expr <- None;
  1908. let is_override = List.memq cf cl.cl_overrides in
  1909. if is_override then begin
  1910. cl.cl_ordered_fields <- List.filter (fun f -> f.cf_name <> cf.cf_name) cl.cl_ordered_fields;
  1911. cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields;
  1912. acc_vars, handle_override_dynfun acc_funs ret var cf.cf_name
  1913. end else if is_var then
  1914. ret :: acc_vars, acc_funs
  1915. else
  1916. acc_vars, ret :: acc_funs
  1917. | None, _ -> acc_vars,acc_funs)
  1918. | _ -> acc_vars,acc_funs
  1919. ) ([],[]) cl.cl_ordered_fields
  1920. in
  1921. (* let vars = List.rev vars in *)
  1922. (* let funs = List.rev funs in *)
  1923. (* see if there is any *)
  1924. (match vars, funs with
  1925. | [], [] -> ()
  1926. | _ ->
  1927. (* if there is, we need to find the constructor *)
  1928. let ctors = match cl.cl_constructor with
  1929. | Some ctor -> ctor
  1930. | None -> try
  1931. let sctor, sup, stl = OverloadingConstructor.prev_ctor cl (List.map snd cl.cl_params) in
  1932. let ctor = OverloadingConstructor.clone_ctors gen sctor sup stl cl in
  1933. cl.cl_constructor <- Some ctor;
  1934. ctor
  1935. with | Not_found ->
  1936. let basic = gen.gcon.basic in
  1937. let ctor = mk_class_field "new" (TFun([], basic.tvoid)) false cl.cl_pos (Method MethNormal) [] in
  1938. ctor.cf_expr <- Some
  1939. {
  1940. eexpr = TFunction {
  1941. tf_args = [];
  1942. tf_type = basic.tvoid;
  1943. tf_expr = { eexpr = TBlock[]; etype = basic.tvoid; epos = cl.cl_pos };
  1944. };
  1945. etype = ctor.cf_type;
  1946. epos = ctor.cf_pos;
  1947. };
  1948. cl.cl_constructor <- Some ctor;
  1949. ctor
  1950. in
  1951. let process ctor =
  1952. let func = match ctor.cf_expr with
  1953. | Some({eexpr = TFunction(tf)} as e) ->
  1954. let rec add_fn e = match e.eexpr with
  1955. | TBlock(hd :: tl) -> (match hd.eexpr with
  1956. | TCall({ eexpr = TConst TSuper }, _) ->
  1957. if not (OverloadingConstructor.descends_from_native_or_skipctor cl) then
  1958. { e with eexpr = TBlock(vars @ (hd :: (funs @ tl))) }
  1959. else
  1960. { e with eexpr = TBlock(hd :: (vars @ funs @ tl)) }
  1961. | TBlock(_) ->
  1962. { e with eexpr = TBlock( (add_fn hd) :: tl ) }
  1963. | _ ->
  1964. { e with eexpr = TBlock( vars @ funs @ (hd :: tl) ) })
  1965. | _ -> Type.concat { e with eexpr = TBlock(vars @ funs) } e
  1966. in
  1967. let tf_expr = add_fn (mk_block tf.tf_expr) in
  1968. { e with eexpr = TFunction({ tf with tf_expr = tf_expr }) }
  1969. | _ -> assert false
  1970. in
  1971. ctor.cf_expr <- Some(func)
  1972. in
  1973. List.iter process (ctors :: ctors.cf_overloads)
  1974. )
  1975. end
  1976. in
  1977. let mod_filter = function
  1978. | TClassDecl cl -> (if not cl.cl_extern then handle_class cl); None
  1979. | _ -> None in
  1980. gen.gmodule_filters#add ~name:"init_funcs" ~priority:(PCustom priority) mod_filter
  1981. end;;
  1982. (* ******************************************* *)
  1983. (* Dynamic Binop/Unop handler *)
  1984. (* ******************************************* *)
  1985. (*
  1986. On some languages there is limited support for operations on
  1987. dynamic variables, so those operations must be changed.
  1988. There are 5 types of binary operators:
  1989. 1 - can take any variable and returns a bool (== and !=)
  1990. 2 - can take either a string, or a number and returns either a bool or the underlying type ( >, < for bool and + for returning its type)
  1991. 3 - take numbers and return a number ( *, /, ...)
  1992. 4 - take ints and return an int (bit manipulation)
  1993. 5 - take a bool and returns a bool ( &&, || ...)
  1994. On the default implementation, type 1 and the plus function will be handled with a function call;
  1995. Type 2 will be handled with the parameter "compare_handler", which will do something like Reflect.compare(x1, x2);
  1996. Types 3, 4 and 5 will perform a cast to double, int and bool, which will then be handled normally by the platform
  1997. Unary operators are the most difficult to handle correctly.
  1998. With unary operators, there are 2 types:
  1999. 1 - can take a number, changes and returns the result (++, --, ~)
  2000. 2 - can take a number (-) or bool (!), and returns the result
  2001. The first case is much trickier, because it doesn't seem a good idea to change any variable to double just because it is dynamic,
  2002. but this is how we will handle right now.
  2003. something like that:
  2004. var x:Dynamic = 10;
  2005. x++;
  2006. will be:
  2007. object x = 10;
  2008. x = ((IConvertible)x).ToDouble(null) + 1;
  2009. depends on:
  2010. (syntax) must run before expression/statment normalization because it may generate complex expressions
  2011. must run before OverloadingCtor due to later priority conflicts. Since ExpressionUnwrap is only
  2012. defined afterwards, we will set this value with absolute values
  2013. *)
  2014. module DynamicOperators =
  2015. struct
  2016. let name = "dyn_ops"
  2017. let priority = 0.0
  2018. let priority_as_synf = 100.0 (*solve_deps name [DBefore ExpressionUnwrap.priority]*)
  2019. let abstract_implementation gen ?(handle_strings = true) (should_change:texpr->bool) (equals_handler:texpr->texpr->texpr) (dyn_plus_handler:texpr->texpr->texpr->texpr) (compare_handler:texpr->texpr->texpr) =
  2020. let get_etype_one e =
  2021. if like_int e.etype then
  2022. (gen.gcon.basic.tint, { eexpr = TConst(TInt(Int32.one)); etype = gen.gcon.basic.tint; epos = e.epos })
  2023. else
  2024. (gen.gcon.basic.tfloat, { eexpr = TConst(TFloat("1.0")); etype = gen.gcon.basic.tfloat; epos = e.epos })
  2025. in
  2026. let basic = gen.gcon.basic in
  2027. let rec run e =
  2028. match e.eexpr with
  2029. | TBinop (OpAssignOp op, e1, e2) when should_change e -> (* e1 will never contain another TBinop *)
  2030. (match e1.eexpr with
  2031. | TLocal _ ->
  2032. mk_paren { e with eexpr = TBinop(OpAssign, e1, run { e with eexpr = TBinop(op, e1, e2) }) }
  2033. | TField _ | TArray _ ->
  2034. let eleft, rest = match e1.eexpr with
  2035. | TField(ef, f) ->
  2036. let v = mk_temp gen "dynop" ef.etype in
  2037. { e1 with eexpr = TField(mk_local v ef.epos, f) }, [ { eexpr = TVar(v,Some (run ef)); etype = basic.tvoid; epos = ef.epos } ]
  2038. | TArray(e1a, e2a) ->
  2039. let v = mk_temp gen "dynop" e1a.etype in
  2040. let v2 = mk_temp gen "dynopi" e2a.etype in
  2041. { e1 with eexpr = TArray(mk_local v e1a.epos, mk_local v2 e2a.epos) }, [
  2042. { eexpr = TVar(v,Some (run e1a)); etype = basic.tvoid; epos = e1.epos };
  2043. { eexpr = TVar(v2, Some (run e2a)); etype = basic.tvoid; epos = e1.epos }
  2044. ]
  2045. | _ -> assert false
  2046. in
  2047. { e with
  2048. eexpr = TBlock (rest @ [ { e with eexpr = TBinop(OpAssign, eleft, run { e with eexpr = TBinop(op, eleft, e2) }) } ]);
  2049. }
  2050. | _ ->
  2051. assert false
  2052. )
  2053. | TBinop (OpAssign, e1, e2)
  2054. | TBinop (OpInterval, e1, e2) -> Type.map_expr run e
  2055. | TBinop (op, e1, e2) when should_change e->
  2056. (match op with
  2057. | OpEq -> (* type 1 *)
  2058. equals_handler (run e1) (run e2)
  2059. | OpNotEq -> (* != -> !equals() *)
  2060. mk_paren { eexpr = TUnop(Ast.Not, Prefix, (equals_handler (run e1) (run e2))); etype = gen.gcon.basic.tbool; epos = e.epos }
  2061. | OpAdd ->
  2062. if handle_strings && (is_string e.etype || is_string e1.etype || is_string e2.etype) then
  2063. { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tstring (run e1), mk_cast gen.gcon.basic.tstring (run e2)) }
  2064. else
  2065. dyn_plus_handler e (run e1) (run e2)
  2066. | OpGt | OpGte | OpLt | OpLte -> (* type 2 *)
  2067. { eexpr = TBinop(op, compare_handler (run e1) (run e2), { eexpr = TConst(TInt(Int32.zero)); etype = gen.gcon.basic.tint; epos = e.epos} ); etype = gen.gcon.basic.tbool; epos = e.epos }
  2068. | OpMult | OpDiv | OpSub | OpMod -> (* always cast everything to double *)
  2069. let etype, _ = get_etype_one e in
  2070. { e with eexpr = TBinop(op, mk_cast etype (run e1), mk_cast etype (run e2)) }
  2071. | OpBoolAnd | OpBoolOr ->
  2072. { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tbool (run e1), mk_cast gen.gcon.basic.tbool (run e2)) }
  2073. | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr ->
  2074. { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tint (run e1), mk_cast gen.gcon.basic.tint (run e2)) }
  2075. | OpAssign | OpAssignOp _ | OpInterval | OpArrow -> assert false)
  2076. | TUnop (Increment as op, flag, e1)
  2077. | TUnop (Decrement as op, flag, e1) when should_change e ->
  2078. (*
  2079. some naming definitions:
  2080. * ret => the returning variable
  2081. * _g => the get body
  2082. * getvar => the get variable expr
  2083. This will work like this:
  2084. - if e1 is a TField, set _g = get body, getvar = (get body).varname
  2085. - if Prefix, return getvar = getvar + 1.0
  2086. - if Postfix, set ret = getvar; getvar = getvar + 1.0; ret;
  2087. *)
  2088. let etype, one = get_etype_one e in
  2089. let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> assert false) in
  2090. let var, getvar =
  2091. match e1.eexpr with
  2092. | TField(fexpr, field) ->
  2093. let tmp = mk_temp gen "getvar" fexpr.etype in
  2094. let var = { eexpr = TVar(tmp, Some(run fexpr)); etype = gen.gcon.basic.tvoid; epos = e.epos } in
  2095. (Some var, { eexpr = TField( { fexpr with eexpr = TLocal(tmp) }, field); etype = etype; epos = e1.epos })
  2096. | _ ->
  2097. (None, e1)
  2098. in
  2099. (match flag with
  2100. | Prefix ->
  2101. let block = (match var with | Some e -> [e] | None -> []) @
  2102. [
  2103. mk_cast etype { e with eexpr = TBinop(OpAssign, getvar,{ eexpr = TBinop(op, mk_cast etype getvar, one); etype = etype; epos = e.epos }); etype = getvar.etype; }
  2104. ]
  2105. in
  2106. { eexpr = TBlock(block); etype = etype; epos = e.epos }
  2107. | Postfix ->
  2108. let ret = mk_temp gen "ret" etype in
  2109. let vars = (match var with Some e -> [e] | None -> []) @ [{ eexpr = TVar(ret, Some (mk_cast etype getvar)); etype = gen.gcon.basic.tvoid; epos = e.epos }] in
  2110. let retlocal = { eexpr = TLocal(ret); etype = etype; epos = e.epos } in
  2111. let block = vars @
  2112. [
  2113. { e with eexpr = TBinop(OpAssign, getvar, { eexpr = TBinop(op, retlocal, one); etype = getvar.etype; epos = e.epos }) };
  2114. retlocal
  2115. ] in
  2116. { eexpr = TBlock(block); etype = etype; epos = e.epos }
  2117. )
  2118. | TUnop (op, flag, e1) when should_change e ->
  2119. let etype = match op with | Not -> gen.gcon.basic.tbool | _ -> gen.gcon.basic.tint in
  2120. mk_paren { eexpr = TUnop(op, flag, mk_cast etype (run e1)); etype = etype; epos = e.epos }
  2121. | _ -> Type.map_expr run e
  2122. in
  2123. run
  2124. let configure gen (mapping_func:texpr->texpr) =
  2125. let map e = Some(mapping_func e) in
  2126. gen.gexpr_filters#add ~name:"dyn_ops" ~priority:(PCustom priority) map
  2127. let configure_as_synf gen (mapping_func:texpr->texpr) =
  2128. let map e = Some(mapping_func e) in
  2129. gen.gexpr_filters#add ~name:"dyn_ops" ~priority:(PCustom priority_as_synf) map
  2130. end;;
  2131. (* ******************************************* *)
  2132. (* Dynamic Field Access *)
  2133. (* ******************************************* *)
  2134. (*
  2135. This module will filter every dynamic field access in haxe.
  2136. On platforms that do not support dynamic access, it is with this that you should
  2137. replace dynamic calls with x.field / Reflect.setField calls, and guess what -
  2138. this is the default implemenation!
  2139. Actually there is a problem with Reflect.setField because it returns void, which is a bad thing for us,
  2140. so even in the default implementation, the function call should be specified to a Reflect.setField version that returns
  2141. the value that was set
  2142. (TODO: should it be separated?)
  2143. As a plus, the default implementation adds something that doesn't hurt anybody, it looks for
  2144. TAnon with Statics / EnumStatics field accesses and transforms them into real static calls.
  2145. This means it will take this
  2146. var m = Math;
  2147. for (i in 0...1000) m.cos(10);
  2148. which is an optimization in dynamic platforms, but performs horribly on strongly typed platforms
  2149. and transform into:
  2150. var m = Math;
  2151. for (i in 0...1000) Math.cos(10);
  2152. (addendum:)
  2153. configure_generate_classes will already take care of generating the reflection-enabled class fields and calling abstract_implementation
  2154. with the right arguments.
  2155. Also
  2156. depends on:
  2157. (ok) must run AFTER Binop/Unop handler - so Unops / Binops are already unrolled
  2158. *)
  2159. module DynamicFieldAccess =
  2160. struct
  2161. let name = "dynamic_field_access"
  2162. let priority = solve_deps name [DAfter DynamicOperators.priority]
  2163. let priority_as_synf = solve_deps name [DAfter DynamicOperators.priority_as_synf]
  2164. (*
  2165. is_dynamic (expr) (field_access_expr) (field) : a function that indicates if the field access should be changed
  2166. change_expr (expr) (field_access_expr) (field) (setting expr) (is_unsafe) : changes the expression
  2167. call_expr (expr) (field_access_expr) (field) (call_params) : changes a call expression
  2168. *)
  2169. let abstract_implementation gen (is_dynamic:texpr->texpr->Type.tfield_access->bool) (change_expr:texpr->texpr->string->texpr option->bool->texpr) (call_expr:texpr->texpr->string->texpr list->texpr) =
  2170. let rec run e =
  2171. match e.eexpr with
  2172. (* class types *)
  2173. | TField(fexpr, f) when is_some (anon_class fexpr.etype) ->
  2174. let decl = get (anon_class fexpr.etype) in
  2175. let name = field_name f in
  2176. (try
  2177. match decl with
  2178. | TClassDecl cl ->
  2179. let cf = PMap.find name cl.cl_statics in
  2180. { e with eexpr = TField({ fexpr with eexpr = TTypeExpr decl }, FStatic(cl, cf)) }
  2181. | TEnumDecl en ->
  2182. let ef = PMap.find name en.e_constrs in
  2183. { e with eexpr = TField({ fexpr with eexpr = TTypeExpr decl }, FEnum(en, ef)) }
  2184. | TAbstractDecl _ -> (* abstracts don't have TFields *) assert false
  2185. | TTypeDecl _ -> (* anon_class doesn't return TTypeDecl *) assert false
  2186. with
  2187. | Not_found -> match f with
  2188. | FStatic(cl,cf) when Meta.has Meta.Extern cf.cf_meta ->
  2189. { e with eexpr = TField({ fexpr with eexpr = TTypeExpr decl }, FStatic(cl, cf)) }
  2190. | _ ->
  2191. change_expr e { fexpr with eexpr = TTypeExpr decl } (field_name f) None true
  2192. )
  2193. | TField(fexpr, f) when is_dynamic e fexpr (f) ->
  2194. change_expr e (run fexpr) (field_name f) None true
  2195. | TCall(
  2196. { eexpr = TField(_, FStatic({ cl_path = ([], "Reflect") }, { cf_name = "field" })) } ,
  2197. [obj; { eexpr = TConst(TString(field)) }]
  2198. ) ->
  2199. let t = match gen.greal_type obj.etype with
  2200. | TDynamic _ | TAnon _ | TMono _ -> t_dynamic
  2201. | t -> t
  2202. in
  2203. change_expr (mk_field_access gen { obj with etype = t } field obj.epos) (run obj) field None false
  2204. | TCall(
  2205. { eexpr = TField(_, FStatic({ cl_path = ([], "Reflect") }, { cf_name = "setField" } )) },
  2206. [obj; { eexpr = TConst(TString(field)) }; evalue]
  2207. ) ->
  2208. change_expr (mk_field_access gen obj field obj.epos) (run obj) field (Some (run evalue)) false
  2209. | TBinop(OpAssign, ({eexpr = TField(fexpr, f)}), evalue) when is_dynamic e fexpr (f) ->
  2210. change_expr e (run fexpr) (field_name f) (Some (run evalue)) true
  2211. | TBinop(OpAssign, { eexpr = TField(fexpr, f) }, evalue) ->
  2212. (match field_access_esp gen fexpr.etype (f) with
  2213. | FClassField(_,_,_,cf,false,t,_) when (try PMap.find cf.cf_name gen.gbase_class_fields == cf with Not_found -> false) ->
  2214. change_expr e (run fexpr) (field_name f) (Some (run evalue)) true
  2215. | _ -> Type.map_expr run e
  2216. )
  2217. (* #if debug *)
  2218. | TBinop(OpAssignOp op, ({eexpr = TField(fexpr, f)}), evalue) when is_dynamic e fexpr (f) -> assert false (* this case shouldn't happen *)
  2219. | TUnop(Increment, _, ({eexpr = TField( ( { eexpr=TLocal(local) } as fexpr ), f)}))
  2220. | TUnop(Decrement, _, ({eexpr = TField( ( { eexpr=TLocal(local) } as fexpr ), f)})) when is_dynamic e fexpr (f) -> assert false (* this case shouldn't happen *)
  2221. (* #end *)
  2222. | TCall( ({ eexpr = TField(fexpr, f) }), params ) when is_dynamic e fexpr (f) ->
  2223. call_expr e (run fexpr) (field_name f) (List.map run params)
  2224. | _ -> Type.map_expr run e
  2225. in run
  2226. (*
  2227. this function will already configure with the abstract implementation, and also will create the needed class fields to
  2228. enable reflection on platforms that don't support reflection.
  2229. this means it will create the following class methods:
  2230. - getField(field, isStatic) - gets the value of the field. isStatic
  2231. - setField -
  2232. -
  2233. *)
  2234. let configure_generate_classes gen optimize (runtime_getset_field:texpr->texpr->string->texpr option->texpr) (runtime_call_expr:texpr->texpr->string->texpr list->texpr) =
  2235. ()
  2236. let configure gen (mapping_func:texpr->texpr) =
  2237. let map e = Some(mapping_func e) in
  2238. gen.gexpr_filters#add ~name:"dynamic_field_access" ~priority:(PCustom(priority)) map
  2239. let configure_as_synf gen (mapping_func:texpr->texpr) =
  2240. let map e = Some(mapping_func e) in
  2241. gen.gexpr_filters#add ~name:"dynamic_field_access" ~priority:(PCustom(priority_as_synf)) map
  2242. end;;
  2243. (* ******************************************* *)
  2244. (* Closure Detection *)
  2245. (* ******************************************* *)
  2246. (*
  2247. Just a small utility filter that detects when a closure must be created.
  2248. On the default implementation, this means when a function field is being accessed
  2249. not via reflection and not to be called instantly
  2250. dependencies:
  2251. must run after DynamicFieldAccess, so any TAnon { Statics / EnumStatics } will be changed to the corresponding TTypeExpr
  2252. *)
  2253. module FilterClosures =
  2254. struct
  2255. let name = "filter_closures"
  2256. let priority = solve_deps name [DAfter DynamicFieldAccess.priority]
  2257. let traverse gen (should_change:texpr->string->bool) (filter:texpr->texpr->string->bool->texpr) =
  2258. let rec run e =
  2259. match e.eexpr with
  2260. (*(* this is precisely the only case where we won't even ask if we should change, because it is a direct use of TClosure *)
  2261. | TCall ( {eexpr = TClosure(e1,s)} as clos, args ) ->
  2262. { e with eexpr = TCall({ clos with eexpr = TClosure(run e1, s) }, List.map run args ) }
  2263. | TCall ( clos, args ) ->
  2264. let rec loop clos = match clos.eexpr with
  2265. | TClosure(e1,s) -> Some (clos, e1, s)
  2266. | TParenthesis p -> loop p
  2267. | _ -> None
  2268. in
  2269. let clos = loop clos in
  2270. (match clos with
  2271. | Some (clos, e1, s) -> { e with eexpr = TCall({ clos with eexpr = TClosure(run e1, s) }, List.map run args ) }
  2272. | None -> Type.map_expr run e)*)
  2273. | TCall({ eexpr = TLocal{ v_name = "__delegate__" } } as local, [del]) ->
  2274. { e with eexpr = TCall(local, [Type.map_expr run del]) }
  2275. | TCall(({ eexpr = TField(_, _) } as ef), params) ->
  2276. { e with eexpr = TCall(Type.map_expr run ef, List.map run params) }
  2277. | TField(ef, FEnum(en, field)) ->
  2278. (* FIXME replace t_dynamic with actual enum Anon field *)
  2279. let ef = run ef in
  2280. (match follow field.ef_type with
  2281. | TFun _ when should_change ef field.ef_name ->
  2282. filter e ef field.ef_name true
  2283. | _ ->
  2284. { e with eexpr = TField(ef, FEnum(en,field)) }
  2285. )
  2286. | TField(({ eexpr = TTypeExpr _ } as tf), f) ->
  2287. (match field_access_esp gen tf.etype (f) with
  2288. | FClassField(_,_,_,cf,_,_,_) ->
  2289. (match cf.cf_kind with
  2290. | Method(MethDynamic)
  2291. | Var _ ->
  2292. e
  2293. | _ when should_change tf cf.cf_name ->
  2294. filter e tf cf.cf_name true
  2295. | _ ->
  2296. e
  2297. )
  2298. | _ -> e)
  2299. | TField(e1, FClosure (Some _, cf)) when should_change e1 cf.cf_name ->
  2300. (match cf.cf_kind with
  2301. | Method MethDynamic | Var _ ->
  2302. Type.map_expr run e
  2303. | _ ->
  2304. filter e (run e1) cf.cf_name false)
  2305. | _ -> Type.map_expr run e
  2306. in
  2307. run
  2308. let configure gen (mapping_func:texpr->texpr) =
  2309. let map e = Some(mapping_func e) in
  2310. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
  2311. end;;
  2312. (* ******************************************* *)
  2313. (* Dynamic TArray Handling *)
  2314. (* ******************************************* *)
  2315. (*
  2316. In some languages you cannot overload the [] operator,
  2317. so we need to decide what is kept as TArray and what gets mapped.
  2318. - in order to do this you must ensure that
  2319. depends on:
  2320. (syntax) must run before expression/statment normalization because it may generate complex expressions
  2321. (ok) must run before binop transformations because it may generate some untreated binop ops
  2322. (ok) must run before dynamic field access is transformed into reflection
  2323. *)
  2324. module TArrayTransform =
  2325. struct
  2326. let name = "dyn_tarray"
  2327. let priority = solve_deps name [DBefore DynamicOperators.priority; DBefore DynamicFieldAccess.priority]
  2328. let priority_as_synf = solve_deps name [DBefore DynamicOperators.priority_as_synf; DBefore DynamicFieldAccess.priority_as_synf]
  2329. (* should change signature: tarray expr -> binop operation -> should change? *)
  2330. let default_implementation gen (should_change:texpr->Ast.binop option->bool) (get_fun:string) (set_fun:string) =
  2331. let basic = gen.gcon.basic in
  2332. let mk_get e e1 e2 =
  2333. let efield = mk_field_access gen e1 get_fun e.epos in
  2334. { e with eexpr = TCall(efield, [e2]) }
  2335. in
  2336. let mk_set e e1 e2 evalue =
  2337. let efield = mk_field_access gen e1 set_fun e.epos in
  2338. { e with eexpr = TCall(efield, [e2; evalue]) }
  2339. in
  2340. let rec run e =
  2341. match e.eexpr with
  2342. | TArray(e1, e2) ->
  2343. (* e1 should always be a var; no need to map there *)
  2344. if should_change e None then mk_get e (run e1) (run e2) else Type.map_expr run e
  2345. | TBinop (Ast.OpAssign, ({ eexpr = TArray(e1a,e2a) } as earray), evalue) when should_change earray (Some Ast.OpAssign) ->
  2346. mk_set e (run e1a) (run e2a) (run evalue)
  2347. | TBinop (Ast.OpAssignOp op,({ eexpr = TArray(e1a,e2a) } as earray) , evalue) when should_change earray (Some (Ast.OpAssignOp op)) ->
  2348. (* cache all arguments in vars so they don't get executed twice *)
  2349. (* let ensure_local gen block name e = *)
  2350. let block = ref [] in
  2351. let arr_local = ensure_local gen block "array" (run e1a) in
  2352. let idx_local = ensure_local gen block "index" (run e2a) in
  2353. block := (mk_set e arr_local idx_local ( { e with eexpr=TBinop(op, mk_get earray arr_local idx_local, run evalue) } )) :: !block;
  2354. { e with eexpr = TBlock (List.rev !block) }
  2355. | TUnop(op, flag, ({ eexpr = TArray(e1a, e2a) } as earray)) ->
  2356. if should_change earray None && match op with | Not | Neg -> false | _ -> true then begin
  2357. let block = ref [] in
  2358. let actual_t = match op with
  2359. | Ast.Increment | Ast.Decrement -> (match follow earray.etype with
  2360. | TInst _ | TAbstract _ | TEnum _ -> earray.etype
  2361. | _ -> basic.tfloat)
  2362. | Ast.Not -> basic.tbool
  2363. | _ -> basic.tint
  2364. in
  2365. let val_v = mk_temp gen "arrVal" actual_t in
  2366. let ret_v = mk_temp gen "arrRet" actual_t in
  2367. let arr_local = ensure_local gen block "arr" (run e1a) in
  2368. let idx_local = ensure_local gen block "arrIndex" (run e2a) in
  2369. let val_local = { earray with eexpr = TLocal(val_v) } in
  2370. let ret_local = { earray with eexpr = TLocal(ret_v) } in
  2371. (* var idx = 1; var val = x._get(idx); var ret = val++; x._set(idx, val); ret; *)
  2372. block := { eexpr = TVar(val_v, Some(mk_get earray arr_local idx_local)); (* var val = x._get(idx) *)
  2373. etype = gen.gcon.basic.tvoid;
  2374. epos = e2a.epos
  2375. } :: !block;
  2376. block := { eexpr = TVar(ret_v, Some { e with eexpr = TUnop(op, flag, val_local) }); (* var ret = val++ *)
  2377. etype = gen.gcon.basic.tvoid;
  2378. epos = e2a.epos
  2379. } :: !block;
  2380. block := (mk_set e arr_local idx_local val_local) (*x._set(idx,val)*) :: !block;
  2381. block := ret_local :: !block;
  2382. { e with eexpr = TBlock (List.rev !block) }
  2383. end else
  2384. Type.map_expr run e
  2385. | _ -> Type.map_expr run e
  2386. in run
  2387. let configure gen (mapping_func:texpr->texpr) =
  2388. let map e = Some(mapping_func e) in
  2389. gen.gexpr_filters#add ~name:"dyn_tarray" ~priority:(PCustom priority) map
  2390. let configure_as_synf gen (mapping_func:texpr->texpr) =
  2391. let map e = Some(mapping_func e) in
  2392. gen.gexpr_filters#add ~name:"dyn_tarray" ~priority:(PCustom priority_as_synf) map
  2393. end;;
  2394. (* ******************************************* *)
  2395. (* Try / Catch + throw native types handling *)
  2396. (* ******************************************* *)
  2397. (*
  2398. Some languages/vm's do not support throwing any kind of value. For them, only
  2399. special kinds of objects can be thrown. Because of this, we must wrap some throw
  2400. statements with an expression, and also we must unwrap it on the catch() phase, and
  2401. maybe manually test with Std.is()
  2402. dependencies:
  2403. must run before dynamic field access (?) TODO review
  2404. It's a syntax filter, as it alters types (throw wrapper)
  2405. *)
  2406. module TryCatchWrapper =
  2407. struct
  2408. let priority = solve_deps "try_catch" [DBefore DynamicFieldAccess.priority]
  2409. (*
  2410. should_wrap : does the type should be wrapped? This of course works on the reverse way, so it tells us if the type should be unwrapped as well
  2411. wrap_throw : the wrapper for throw (throw expr->expr inside throw->returning wrapped expression)
  2412. unwrap_expr : the other way around : given the catch var (maybe will need casting to wrapper_type) , return the unwrap expr
  2413. rethrow_expr : how to rethrow ane exception in the platform
  2414. catchall_type : the class used for catchall (e:Dynamic)
  2415. wrapper_type : the wrapper type, so we can test if exception is of type 'wrapper'
  2416. catch_map : maps the catch expression to include some intialization code (e.g. setting up Stack.exceptionStack)
  2417. *)
  2418. let traverse gen (should_wrap:t->bool) (wrap_throw:texpr->texpr->texpr) (unwrap_expr:tvar->pos->texpr) (rethrow_expr:texpr->texpr) (catchall_type:t) (wrapper_type:t) (catch_map:tvar->texpr->texpr) =
  2419. let rec run e =
  2420. match e.eexpr with
  2421. | TThrow texpr when should_wrap texpr.etype -> wrap_throw e (run texpr)
  2422. | TTry (ttry, catches) ->
  2423. let nowrap_catches, must_wrap_catches, catchall = List.fold_left (fun (nowrap_catches, must_wrap_catches, catchall) (v, catch) ->
  2424. (* first we'll see if the type is Dynamic (catchall) *)
  2425. match follow v.v_type with
  2426. | TDynamic _ ->
  2427. assert (is_none catchall);
  2428. (nowrap_catches, must_wrap_catches, Some(v,run catch))
  2429. (* see if we should unwrap it *)
  2430. | _ when should_wrap (follow v.v_type) ->
  2431. (nowrap_catches, (v,run catch) :: must_wrap_catches, catchall)
  2432. | _ ->
  2433. ( (v,catch_map v (run catch)) :: nowrap_catches, must_wrap_catches, catchall )
  2434. ) ([], [], None) catches
  2435. in
  2436. (* temp (?) fix for https://github.com/HaxeFoundation/haxe/issues/4134 *)
  2437. let must_wrap_catches = List.rev must_wrap_catches in
  2438. (*
  2439. 1st catch all nowrap "the easy way"
  2440. 2nd see if there are any must_wrap or catchall. If there is,
  2441. do a catchall first with a temp var.
  2442. then get catchall var (as dynamic) (or create one), and declare it = catchall exception
  2443. then test if it is of type wrapper_type. If it is, unwrap it
  2444. then start doing Std.is() tests for each catch type
  2445. if there is a catchall in the end, end with it. If there isn't, rethrow
  2446. *)
  2447. let dyn_catch = match (catchall, must_wrap_catches) with
  2448. | Some (v,c), _
  2449. | _, (v, c) :: _ ->
  2450. let pos = c.epos in
  2451. let temp_var = mk_temp gen "catchallException" catchall_type in
  2452. let temp_local = { eexpr=TLocal(temp_var); etype = temp_var.v_type; epos = pos } in
  2453. let catchall_var = (*match catchall with
  2454. | None -> *) mk_temp gen "catchall" t_dynamic
  2455. (*| Some (v,_) -> v*)
  2456. in
  2457. let catchall_decl = { eexpr = TVar(catchall_var, Some(temp_local)); etype=gen.gcon.basic.tvoid; epos = pos } in
  2458. let catchall_local = { eexpr = TLocal(catchall_var); etype = t_dynamic; epos = pos } in
  2459. (* if it is of type wrapper_type, unwrap it *)
  2460. let std_is = mk_static_field_access (get_cl (get_type gen ([],"Std"))) "is" (TFun(["v",false,t_dynamic;"cl",false,mt_to_t (get_type gen ([], "Class")) [t_dynamic]],gen.gcon.basic.tbool)) pos in
  2461. let mk_std_is t pos = { eexpr = TCall(std_is, [catchall_local; mk_mt_access (t_to_mt t) pos]); etype = gen.gcon.basic.tbool; epos = pos } in
  2462. let if_is_wrapper_expr = { eexpr = TIf(mk_std_is wrapper_type pos,
  2463. { eexpr = TBinop(OpAssign, catchall_local, unwrap_expr temp_var pos); etype = t_dynamic; epos = pos }
  2464. , None); etype = gen.gcon.basic.tvoid; epos = pos } in
  2465. let rec loop must_wrap_catches = match must_wrap_catches with
  2466. | (vcatch,catch) :: tl ->
  2467. { eexpr = TIf(mk_std_is vcatch.v_type catch.epos,
  2468. { eexpr = TBlock({ eexpr=TVar(vcatch, Some(mk_cast vcatch.v_type catchall_local)); etype=gen.gcon.basic.tvoid; epos=catch.epos } :: [catch] ); etype = catch.etype; epos = catch.epos },
  2469. Some (loop tl));
  2470. etype = catch.etype; epos = catch.epos }
  2471. | [] ->
  2472. match catchall with
  2473. | Some (v,s) ->
  2474. Type.concat { eexpr = TVar(v, Some(catchall_local)); etype = gen.gcon.basic.tvoid; epos = pos } s
  2475. | None ->
  2476. mk_block (rethrow_expr temp_local)
  2477. in
  2478. [ ( temp_var, catch_map temp_var { e with eexpr = TBlock([ catchall_decl; if_is_wrapper_expr; loop must_wrap_catches ]) } ) ]
  2479. | _ ->
  2480. []
  2481. in
  2482. { e with eexpr = TTry(run ttry, (List.rev nowrap_catches) @ dyn_catch) }
  2483. | _ -> Type.map_expr run e
  2484. in
  2485. run
  2486. let configure gen (mapping_func:texpr->texpr) =
  2487. let map e = Some(mapping_func e) in
  2488. gen.gsyntax_filters#add ~name:"try_catch" ~priority:(PCustom priority) map
  2489. end;;
  2490. let fun_args = List.map (function | (v,s) -> (v.v_name, (match s with | None -> false | Some _ -> true), v.v_type))
  2491. (* ******************************************* *)
  2492. (* Closures To Class *)
  2493. (* ******************************************* *)
  2494. (*
  2495. This is a very important filter. It will take all anonymous functions from the AST, will search for all captured variables, and will create a class
  2496. that implements an abstract interface for calling functions. This is very important for targets that don't support anonymous functions to work correctly.
  2497. Also it is possible to implement some strategies to avoid value type boxing, such as NaN tagging or double/object arguments. All this will be abstracted away
  2498. from this interface.
  2499. dependencies:
  2500. must run after dynamic field access, because of conflicting ways to deal with invokeField
  2501. (module filter) must run after OverloadingCtor so we can also change the dynamic function expressions
  2502. uses TArray expressions for array. TODO see interaction
  2503. uses TThrow expressions.
  2504. *)
  2505. module ClosuresToClass =
  2506. struct
  2507. let name = "closures_to_class"
  2508. let priority = solve_deps name [ DAfter DynamicFieldAccess.priority ]
  2509. let priority_as_synf = solve_deps name [ DAfter DynamicFieldAccess.priority_as_synf ]
  2510. type closures_ctx =
  2511. {
  2512. fgen : generator_ctx;
  2513. mutable func_class : tclass;
  2514. (*
  2515. this is what will actually turn the function into class field.
  2516. The standard implementation by default will already take care of creating the class, and setting the captured variables.
  2517. It will also return the super arguments to be called
  2518. *)
  2519. mutable closure_to_classfield : tfunc->t->pos->tclass_field * (texpr list);
  2520. (*
  2521. when a dynamic function call is made, we need to convert it as if it were calling the dynamic function interface.
  2522. TCall expr -> new TCall expr
  2523. *)
  2524. mutable dynamic_fun_call : texpr->texpr;
  2525. (*
  2526. called once so the implementation can make one of a time initializations in the base class
  2527. for all functions
  2528. *)
  2529. mutable initialize_base_class : tclass->unit;
  2530. (*
  2531. Base classfields are the class fields for the abstract implementation of either the Function implementation,
  2532. or the invokeField implementation for the classes
  2533. They will either try to call the right function or will fail with
  2534. (tclass - subject (so we know the type of this)) -> is_function_base -> additional arguments for each function (at the beginning) -> list of the abstract implementation class fields
  2535. *)
  2536. mutable get_base_classfields_for : tclass->bool->(unit->(tvar * tconstant option) list)->tclass_field list;
  2537. (*
  2538. This is a more complex version of get_base_classfields_for.
  2539. It's meant to provide a toolchain so we can easily create classes that extend Function
  2540. and add more functionality on top of it.
  2541. arguments:
  2542. tclass -> subject (so we know the type of this)
  2543. bool -> is it a function type
  2544. ( int -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) )
  2545. int -> current arity of the function whose member will be mapped; -1 for dynamic function. It is guaranteed that dynamic function will be called last
  2546. t -> the return type of the function
  2547. (int->t->tconstant option->texpr) -> api to get exprs that unwrap arguments correctly
  2548. int -> argument wanted to unwrap
  2549. t -> solicited type
  2550. tconstant option -> map to this default value if null
  2551. returns a texpr that tells how the default
  2552. should return a list with additional arguments (only works if is_function_base = true)
  2553. and the underlying function expression
  2554. *)
  2555. mutable map_base_classfields : tclass->bool->( int -> t -> (tvar list) -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) )->tclass_field list;
  2556. mutable transform_closure : texpr->texpr->string->texpr;
  2557. }
  2558. type map_info = {
  2559. in_unsafe : bool;
  2560. in_unused : bool;
  2561. }
  2562. let null_map_info = { in_unsafe = false; in_unused = false; }
  2563. (*
  2564. the default implementation will take 3 transformation functions:
  2565. * one that will transform closures that are not called immediately (instance.myFunc).
  2566. normally on this case it's best to have a runtime handler that will take the instance, the function and call its invokeField when invoked
  2567. * one that will actually handle the anonymous functions themselves.
  2568. * one that will transform calling a dynamic function. So for example, dynFunc(arg1, arg2) might turn into dynFunc.apply2(arg1, arg2);
  2569. ( suspended ) * an option to match papplied functions
  2570. * handling parameterized anonymous function declaration (optional - tparam_anon_decl and tparam_anon_acc)
  2571. *)
  2572. let rec cleanup_delegate e = match e.eexpr with
  2573. | TParenthesis e | TMeta(_,e)
  2574. | TCast(e,_) -> cleanup_delegate e
  2575. | _ -> e
  2576. let funct gen t = match follow (run_follow gen t) with
  2577. | TFun(args,ret) -> args,ret
  2578. | _ -> raise Not_found
  2579. let mk_conversion_fun gen e =
  2580. let args, ret = funct gen e.etype in
  2581. let tf_args = List.map (fun (n,o,t) -> alloc_var n t,None) args in
  2582. let block, local = match e.eexpr with
  2583. | TLocal v ->
  2584. v.v_capture <- true;
  2585. [],e
  2586. | _ ->
  2587. let tmp = mk_temp gen "delegate_conv" e.etype in
  2588. tmp.v_capture <- true;
  2589. [{ eexpr = TVar(tmp,Some e); etype = gen.gcon.basic.tvoid; epos = e.epos }], mk_local tmp e.epos
  2590. in
  2591. let body = {
  2592. eexpr = TCall(local, List.map (fun (v,_) -> mk_local v e.epos) tf_args);
  2593. etype = ret;
  2594. epos = e.epos;
  2595. } in
  2596. let body = if not (is_void ret) then
  2597. { body with eexpr = TReturn( Some body ) }
  2598. else
  2599. body
  2600. in
  2601. let body = {
  2602. eexpr = TBlock(block @ [body]);
  2603. etype = body.etype;
  2604. epos = body.epos;
  2605. } in
  2606. {
  2607. tf_args = tf_args;
  2608. tf_expr = body;
  2609. tf_type = ret;
  2610. }
  2611. let traverse gen ?tparam_anon_decl ?tparam_anon_acc (transform_closure:texpr->texpr->string->texpr) (handle_anon_func:texpr->tfunc->map_info->t option->texpr) (dynamic_func_call:texpr->texpr) e =
  2612. let info = ref null_map_info in
  2613. let rec run e =
  2614. match e.eexpr with
  2615. | TCast({ eexpr = TCall({ eexpr = TLocal{ v_name = "__delegate__" } } as local, [del] ) } as e2, _) ->
  2616. let e2 = { e2 with etype = e.etype } in
  2617. let replace_delegate ex =
  2618. { e with eexpr = TCast({ e2 with eexpr = TCall(local, [ex]) }, None) }
  2619. in
  2620. (* found a delegate; let's see if it's a closure or not *)
  2621. let clean = cleanup_delegate del in
  2622. (match clean.eexpr with
  2623. | TField( ef, (FClosure _ as f)) | TField( ef, (FStatic _ as f)) ->
  2624. (* a closure; let's leave this unchanged for FilterClosures to handle it *)
  2625. replace_delegate { clean with eexpr = TField( run ef, f ) }
  2626. | TFunction tf ->
  2627. (* handle like we'd handle a normal function, but create an unchanged closure field for it *)
  2628. let ret = handle_anon_func clean { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
  2629. replace_delegate ret
  2630. | _ -> try
  2631. let tf = mk_conversion_fun gen del in
  2632. let ret = handle_anon_func del { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
  2633. replace_delegate ret
  2634. with Not_found ->
  2635. gen.gcon.error "This delegate construct is unsupported" e.epos;
  2636. replace_delegate (run clean))
  2637. | TCall(({ eexpr = TLocal{ v_name = "__unsafe__" } } as local), [arg]) ->
  2638. let old = !info in
  2639. info := { !info with in_unsafe = true };
  2640. let arg2 = run arg in
  2641. info := old;
  2642. { e with eexpr = TCall(local,[arg2]) }
  2643. (* parameterized functions handling *)
  2644. | TVar(vv, ve) -> (match tparam_anon_decl with
  2645. | None -> Type.map_expr run e
  2646. | Some tparam_anon_decl ->
  2647. (match (vv, ve) with
  2648. | ({ v_extra = Some( _ :: _, _) } as v), Some ({ eexpr = TFunction tf } as f)
  2649. | ({ v_extra = Some( _ :: _, _) } as v), Some { eexpr = TArrayDecl([{ eexpr = TFunction tf } as f]) | TCall({ eexpr = TLocal { v_name = "__array__" } }, [{ eexpr = TFunction tf } as f]) } -> (* captured transformation *)
  2650. ignore(tparam_anon_decl v f { tf with tf_expr = run tf.tf_expr });
  2651. { e with eexpr = TBlock([]) }
  2652. | _ ->
  2653. Type.map_expr run { e with eexpr = TVar(vv, ve) })
  2654. )
  2655. | TLocal ({ v_extra = Some( _ :: _, _) } as v)
  2656. | TArray ({ eexpr = TLocal ({ v_extra = Some( _ :: _, _) } as v) }, _) -> (* captured transformation *)
  2657. (match tparam_anon_acc with
  2658. | None -> Type.map_expr run e
  2659. | Some tparam_anon_acc -> tparam_anon_acc v e)
  2660. | TCall( { eexpr = TField(_, FEnum _) }, _ ) ->
  2661. Type.map_expr run e
  2662. (* if a TClosure is being call immediately, there's no need to convert it to a TClosure *)
  2663. | TCall(( { eexpr = TField(ecl,f) } as e1), params) ->
  2664. (* check to see if called field is known and if it is a MethNormal (only MethNormal fields can be called directly) *)
  2665. (* let name = field_name f in *)
  2666. (match field_access_esp gen (gen.greal_type ecl.etype) f with
  2667. | FClassField(_,_,_,cf,_,_,_) ->
  2668. (match cf.cf_kind with
  2669. | Method MethNormal
  2670. | Method MethInline ->
  2671. { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
  2672. | _ ->
  2673. match gen.gfollow#run_f e1.etype with
  2674. | TFun _ ->
  2675. dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
  2676. | _ ->
  2677. let i = ref 0 in
  2678. let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
  2679. dynamic_func_call { e with eexpr = TCall( mk_cast t (run e1), List.map run params ) }
  2680. )
  2681. (* | FNotFound ->
  2682. { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
  2683. (* expressions by now may have generated invalid expressions *) *)
  2684. | _ ->
  2685. match gen.gfollow#run_f e1.etype with
  2686. | TFun _ ->
  2687. dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
  2688. | _ ->
  2689. let i = ref 0 in
  2690. let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
  2691. dynamic_func_call { e with eexpr = TCall( mk_cast t (run e1), List.map run params ) }
  2692. )
  2693. | TField(ecl, FClosure (_,cf)) ->
  2694. transform_closure e (run ecl) cf.cf_name
  2695. | TFunction tf ->
  2696. handle_anon_func e { tf with tf_expr = run tf.tf_expr } !info None
  2697. | TCall({ eexpr = TConst(TSuper) }, _) ->
  2698. Type.map_expr run e
  2699. | TCall({ eexpr = TLocal(v) }, args) when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name ->
  2700. Type.map_expr run e
  2701. | TCall(tc,params) ->
  2702. let i = ref 0 in
  2703. let may_cast = match gen.gfollow#run_f tc.etype with
  2704. | TFun _ -> fun e -> e
  2705. | _ ->
  2706. let t = TFun(List.map (fun e ->
  2707. incr i;
  2708. ("p" ^ (string_of_int !i), false, e.etype)
  2709. ) params, e.etype)
  2710. in
  2711. fun e -> mk_cast t e
  2712. in
  2713. dynamic_func_call { e with eexpr = TCall(run (may_cast tc), List.map run params) }
  2714. | _ -> Type.map_expr run e
  2715. in
  2716. (match e.eexpr with
  2717. | TFunction(tf) -> Type.map_expr run e
  2718. | _ -> run e)
  2719. let rec get_type_params acc t =
  2720. match t with
  2721. | TInst(( { cl_kind = KTypeParameter _ } as cl), []) ->
  2722. if List.memq cl acc then acc else cl :: acc
  2723. | TFun (params,tret) ->
  2724. List.fold_left get_type_params acc ( tret :: List.map (fun (_,_,t) -> t) params )
  2725. | TDynamic t ->
  2726. (match t with | TDynamic _ -> acc | _ -> get_type_params acc t)
  2727. | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
  2728. get_type_params acc ( Abstract.get_underlying_type a pl)
  2729. | TAnon a ->
  2730. PMap.fold (fun cf acc ->
  2731. let params = List.map (fun (_,t) -> match follow t with
  2732. | TInst(c,_) -> c
  2733. | _ -> assert false) cf.cf_params
  2734. in
  2735. List.filter (fun t -> not (List.memq t params)) (get_type_params acc cf.cf_type)
  2736. ) a.a_fields acc
  2737. | TType(_, [])
  2738. | TAbstract (_, [])
  2739. | TInst(_, [])
  2740. | TEnum(_, []) ->
  2741. acc
  2742. | TType(_, params)
  2743. | TAbstract(_, params)
  2744. | TEnum(_, params)
  2745. | TInst(_, params) ->
  2746. List.fold_left get_type_params acc params
  2747. | TMono r -> (match !r with
  2748. | Some t -> get_type_params acc t
  2749. | None -> acc)
  2750. | _ -> get_type_params acc (follow_once t)
  2751. let get_captured expr =
  2752. let ret = Hashtbl.create 1 in
  2753. let ignored = Hashtbl.create 0 in
  2754. let params = ref [] in
  2755. let check_params t = params := get_type_params !params t in
  2756. let rec traverse expr =
  2757. match expr.eexpr with
  2758. | TFor (v, _, _) ->
  2759. Hashtbl.add ignored v.v_id v;
  2760. check_params v.v_type;
  2761. Type.iter traverse expr
  2762. | TFunction(tf) ->
  2763. List.iter (fun (v,_) -> Hashtbl.add ignored v.v_id v) tf.tf_args;
  2764. (match follow expr.etype with
  2765. | TFun(args,ret) ->
  2766. List.iter (fun (_,_,t) ->
  2767. check_params t
  2768. ) args;
  2769. check_params ret
  2770. | _ -> ());
  2771. Type.iter traverse expr
  2772. | TVar (v, opt) ->
  2773. (match v.v_extra with
  2774. | Some(_ :: _, _) -> ()
  2775. | _ ->
  2776. check_params v.v_type);
  2777. Hashtbl.add ignored v.v_id v;
  2778. ignore(Option.map traverse opt)
  2779. | TLocal { v_extra = Some( (_ :: _ ),_) } ->
  2780. ()
  2781. | TLocal(( { v_capture = true } ) as v) ->
  2782. (if not (Hashtbl.mem ignored v.v_id || Hashtbl.mem ret v.v_id) then begin check_params v.v_type; Hashtbl.replace ret v.v_id expr end);
  2783. | _ -> Type.iter traverse expr
  2784. in traverse expr;
  2785. ret, !params
  2786. (*
  2787. OPTIMIZEME:
  2788. Take off from Codegen the code that wraps captured variables,
  2789. traverse through all variables, looking for their use (just like local_usage)
  2790. three possible outcomes for captured variables:
  2791. - become a function member variable <- best performance.
  2792. Will not work on functions that can be created more than once (functions inside a loop or functions inside functions)
  2793. The function will have to be created on top of the block, so its variables can be filled in instead of being declared
  2794. - single-element array - the most compatible way, though also creates a slight overhead.
  2795. - we'll have some labels for captured variables:
  2796. - used in loop
  2797. *)
  2798. (*
  2799. The default implementation will impose a naming convention:
  2800. invoke(arity)_(o for returning object/d for returning double) when arity < max_arity
  2801. invoke_dynamic_(o/d) when arity > max_arity
  2802. This means that it also imposes that the dynamic function return types may only be Dynamic or Float, and all other basic types must be converted to/from it.
  2803. *)
  2804. let default_implementation ft parent_func_class (* e.g. new haxe.lang.ClassClosure *) =
  2805. let gen = ft.fgen in
  2806. ft.initialize_base_class parent_func_class;
  2807. let cfs = ft.get_base_classfields_for parent_func_class true (fun () -> []) in
  2808. List.iter (fun cf ->
  2809. (if cf.cf_name = "new" then parent_func_class.cl_constructor <- Some cf else
  2810. parent_func_class.cl_fields <- PMap.add cf.cf_name cf parent_func_class.cl_fields
  2811. )
  2812. ) cfs;
  2813. parent_func_class.cl_ordered_fields <- (List.filter (fun cf -> cf.cf_name <> "new") cfs) @ parent_func_class.cl_ordered_fields;
  2814. ft.func_class <- parent_func_class;
  2815. let handle_anon_func fexpr tfunc mapinfo delegate_type : texpr * (tclass * texpr list) =
  2816. let gen = ft.fgen in
  2817. let in_unsafe = mapinfo.in_unsafe || match gen.gcurrent_class, gen.gcurrent_classfield with
  2818. | Some c, _ when Meta.has Meta.Unsafe c.cl_meta -> true
  2819. | _, Some cf when Meta.has Meta.Unsafe cf.cf_meta -> true
  2820. | _ -> false
  2821. in
  2822. (* get all captured variables it uses *)
  2823. let captured_ht, tparams = get_captured fexpr in
  2824. let captured = Hashtbl.fold (fun _ e acc -> e :: acc) captured_ht [] in
  2825. let captured = List.sort (fun e1 e2 -> match e1, e2 with
  2826. | { eexpr = TLocal v1 }, { eexpr = TLocal v2 } ->
  2827. compare v1.v_name v2.v_name
  2828. | _ -> assert false) captured
  2829. in
  2830. (*let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(map_param cl, []) )) tparams in*)
  2831. let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(cl, []) )) tparams in
  2832. (* create a new class that extends abstract function class, with a ctor implementation that will setup all captured variables *)
  2833. let cfield = match ft.fgen.gcurrent_classfield with
  2834. | None -> "Anon"
  2835. | Some cf -> cf.cf_name
  2836. in
  2837. let cur_line = Lexer.get_error_line fexpr.epos in
  2838. let path = (fst ft.fgen.gcurrent_path, Printf.sprintf "%s_%s_%d__Fun" (snd ft.fgen.gcurrent_path) cfield cur_line) in
  2839. let cls = mk_class (get ft.fgen.gcurrent_class).cl_module path tfunc.tf_expr.epos in
  2840. if in_unsafe then cls.cl_meta <- (Meta.Unsafe,[],Ast.null_pos) :: cls.cl_meta;
  2841. if Common.defined gen.gcon Define.EraseGenerics then begin
  2842. cls.cl_meta <- (Meta.HaxeGeneric,[],Ast.null_pos) :: cls.cl_meta
  2843. end;
  2844. cls.cl_module <- (get ft.fgen.gcurrent_class).cl_module;
  2845. cls.cl_params <- cltypes;
  2846. let mk_this v pos =
  2847. {
  2848. (mk_field_access gen { eexpr = TConst TThis; etype = TInst(cls, List.map snd cls.cl_params); epos = pos } v.v_name pos)
  2849. with etype = v.v_type
  2850. }
  2851. in
  2852. let mk_this_assign v pos =
  2853. {
  2854. eexpr = TBinop(OpAssign, mk_this v pos, { eexpr = TLocal(v); etype = v.v_type; epos = pos });
  2855. etype = v.v_type;
  2856. epos = pos
  2857. } in
  2858. (* mk_class_field name t public pos kind params *)
  2859. let ctor_args, ctor_sig, ctor_exprs = List.fold_left (fun (ctor_args, ctor_sig, ctor_exprs) lexpr ->
  2860. match lexpr.eexpr with
  2861. | TLocal(v) ->
  2862. let cf = mk_class_field v.v_name v.v_type false lexpr.epos (Var({ v_read = AccNormal; v_write = AccNormal; })) [] in
  2863. cls.cl_fields <- PMap.add v.v_name cf cls.cl_fields;
  2864. cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
  2865. let ctor_v = alloc_var v.v_name v.v_type in
  2866. ((ctor_v, None) :: ctor_args, (v.v_name, false, v.v_type) :: ctor_sig, (mk_this_assign v cls.cl_pos) :: ctor_exprs)
  2867. | _ -> assert false
  2868. ) ([],[],[]) captured in
  2869. (* change all captured variables to this.capturedVariable *)
  2870. let rec change_captured e =
  2871. match e.eexpr with
  2872. | TLocal( ({ v_capture = true }) as v ) when Hashtbl.mem captured_ht v.v_id ->
  2873. mk_this v e.epos
  2874. | _ -> Type.map_expr change_captured e
  2875. in
  2876. let func_expr = change_captured tfunc.tf_expr in
  2877. let invokecf, invoke_field, super_args = match delegate_type with
  2878. | None -> (* no delegate *)
  2879. let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = func_expr } fexpr.etype fexpr.epos in
  2880. ifield,ifield,sa
  2881. | Some _ ->
  2882. let pos = cls.cl_pos in
  2883. let cf = mk_class_field "Delegate" (TFun(fun_args tfunc.tf_args, tfunc.tf_type)) true pos (Method MethNormal) [] in
  2884. cf.cf_expr <- Some { fexpr with eexpr = TFunction { tfunc with tf_expr = func_expr }; };
  2885. cf.cf_meta <- (Meta.Final,[],pos) :: cf.cf_meta;
  2886. cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
  2887. cls.cl_fields <- PMap.add cf.cf_name cf cls.cl_fields;
  2888. (* invoke function body: call Delegate function *)
  2889. let ibody = {
  2890. eexpr = TCall({
  2891. eexpr = TField({
  2892. eexpr = TConst TThis;
  2893. etype = TInst(cls, List.map snd cls.cl_params);
  2894. epos = pos;
  2895. }, FInstance(cls, List.map snd cls.cl_params, cf));
  2896. etype = cf.cf_type;
  2897. epos = pos;
  2898. }, List.map (fun (v,_) -> mk_local v pos) tfunc.tf_args);
  2899. etype = tfunc.tf_type;
  2900. epos = pos
  2901. } in
  2902. let ibody = if not (is_void tfunc.tf_type) then
  2903. { ibody with eexpr = TReturn( Some ibody ) }
  2904. else
  2905. ibody
  2906. in
  2907. let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = ibody } fexpr.etype fexpr.epos in
  2908. cf,ifield,sa
  2909. in
  2910. (* create the constructor *)
  2911. (* todo properly abstract how type var is set *)
  2912. cls.cl_super <- Some(parent_func_class, []);
  2913. let pos = cls.cl_pos in
  2914. let super_call =
  2915. {
  2916. eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(parent_func_class,[]); epos = pos }, super_args);
  2917. etype = ft.fgen.gcon.basic.tvoid;
  2918. epos = pos;
  2919. } in
  2920. let ctor_type = (TFun(ctor_sig, ft.fgen.gcon.basic.tvoid)) in
  2921. let ctor = mk_class_field "new" ctor_type true cls.cl_pos (Method(MethNormal)) [] in
  2922. ctor.cf_expr <- Some(
  2923. {
  2924. eexpr = TFunction(
  2925. {
  2926. tf_args = ctor_args;
  2927. tf_type = ft.fgen.gcon.basic.tvoid;
  2928. tf_expr = { eexpr = TBlock(super_call :: ctor_exprs); etype = ft.fgen.gcon.basic.tvoid; epos = cls.cl_pos }
  2929. });
  2930. etype = ctor_type;
  2931. epos = cls.cl_pos;
  2932. });
  2933. cls.cl_constructor <- Some(ctor);
  2934. (* add invoke function to the class *)
  2935. cls.cl_ordered_fields <- invoke_field :: cls.cl_ordered_fields;
  2936. cls.cl_fields <- PMap.add invoke_field.cf_name invoke_field cls.cl_fields;
  2937. cls.cl_overrides <- invoke_field :: cls.cl_overrides;
  2938. (* add this class to the module with gadd_to_module *)
  2939. ft.fgen.gadd_to_module (TClassDecl(cls)) priority;
  2940. (* if there are no captured variables, we can create a cache so subsequent calls don't need to create a new function *)
  2941. let expr, clscapt =
  2942. match captured, tparams with
  2943. | [], [] ->
  2944. let cache_var = ft.fgen.gmk_internal_name "hx" "current" in
  2945. let cache_cf = mk_class_field cache_var (TInst(cls,[])) false func_expr.epos (Var({ v_read = AccNormal; v_write = AccNormal })) [] in
  2946. cls.cl_ordered_statics <- cache_cf :: cls.cl_ordered_statics;
  2947. cls.cl_statics <- PMap.add cache_var cache_cf cls.cl_statics;
  2948. (* if (FuncClass.hx_current != null) FuncClass.hx_current; else (FuncClass.hx_current = new FuncClass()); *)
  2949. (* let mk_static_field_access cl field fieldt pos = *)
  2950. let hx_current = mk_static_field_access cls cache_var (TInst(cls,[])) func_expr.epos in
  2951. let pos = func_expr.epos in
  2952. { fexpr with
  2953. eexpr = TIf(
  2954. {
  2955. eexpr = TBinop(OpNotEq, hx_current, null (TInst(cls,[])) pos);
  2956. etype = ft.fgen.gcon.basic.tbool;
  2957. epos = pos;
  2958. },
  2959. hx_current,
  2960. Some(
  2961. {
  2962. eexpr = TBinop(OpAssign, hx_current, { fexpr with eexpr = TNew(cls, [], captured) });
  2963. etype = (TInst(cls,[]));
  2964. epos = pos;
  2965. }))
  2966. }, (cls,captured)
  2967. | _ ->
  2968. (* change the expression so it will be a new "added class" ( captured variables arguments ) *)
  2969. { fexpr with eexpr = TNew(cls, List.map (fun cl -> TInst(cl,[])) tparams, List.rev captured) }, (cls,captured)
  2970. in
  2971. match delegate_type with
  2972. | None ->
  2973. expr,clscapt
  2974. | Some _ ->
  2975. {
  2976. eexpr = TField(expr, FClosure(Some (cls,[]),invokecf)); (* TODO: FClosure change *)
  2977. etype = invokecf.cf_type;
  2978. epos = cls.cl_pos
  2979. }, clscapt
  2980. in
  2981. let tvar_to_cdecl = Hashtbl.create 0 in
  2982. traverse
  2983. ft.fgen
  2984. ~tparam_anon_decl:(fun v e fn ->
  2985. let _, info = handle_anon_func e fn null_map_info None in
  2986. Hashtbl.add tvar_to_cdecl v.v_id info
  2987. )
  2988. ~tparam_anon_acc:(fun v e -> try
  2989. let cls, captured = Hashtbl.find tvar_to_cdecl v.v_id in
  2990. let types = match v.v_extra with
  2991. | Some(t,_) -> t
  2992. | _ -> assert false
  2993. in
  2994. let monos = List.map (fun _ -> mk_mono()) types in
  2995. let vt = match follow v.v_type with
  2996. | TInst(_, [v]) -> v
  2997. | v -> v
  2998. in
  2999. let et = match follow e.etype with
  3000. | TInst(_, [v]) -> v
  3001. | v -> v
  3002. in
  3003. let original = apply_params types monos vt in
  3004. unify et original;
  3005. let monos = List.map (fun t -> apply_params types (List.map (fun _ -> t_dynamic) types) t) monos in
  3006. let same_cl t1 t2 = match follow t1, follow t2 with
  3007. | TInst(c,_), TInst(c2,_) -> c == c2
  3008. | _ -> false
  3009. in
  3010. let passoc = List.map2 (fun (_,t) m -> t,m) types monos in
  3011. let cltparams = List.map (fun (_,t) ->
  3012. try
  3013. snd (List.find (fun (t2,_) -> same_cl t t2) passoc)
  3014. with | Not_found -> t) cls.cl_params
  3015. in
  3016. { e with eexpr = TNew(cls, cltparams, captured) }
  3017. with
  3018. | Not_found ->
  3019. gen.gcon.warning "This expression may be invalid" e.epos;
  3020. e
  3021. | Unify_error el ->
  3022. List.iter (fun el -> gen.gcon.warning (Typecore.unify_error_msg (print_context()) el) e.epos) el;
  3023. gen.gcon.warning "This expression may be invalid" e.epos;
  3024. e
  3025. )
  3026. (* (transform_closure:texpr->texpr->string->texpr) (handle_anon_func:texpr->tfunc->texpr) (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
  3027. ft.transform_closure
  3028. (fun e f info delegate_type -> fst (handle_anon_func e f info delegate_type))
  3029. ft.dynamic_fun_call
  3030. (* (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
  3031. let configure gen (mapping_func:texpr->texpr) =
  3032. let map e = Some(mapping_func e) in
  3033. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
  3034. let configure_as_synf gen (mapping_func:texpr->texpr) =
  3035. let map e = Some(mapping_func e) in
  3036. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority_as_synf) map
  3037. (*
  3038. this submodule will provide the default implementation for the C# and Java targets.
  3039. it will have two return types: double and dynamic, and
  3040. *)
  3041. module DoubleAndDynamicClosureImpl =
  3042. struct
  3043. let get_ctx gen max_arity =
  3044. let basic = gen.gcon.basic in
  3045. let func_args_i i =
  3046. let rec loop i (acc) =
  3047. if i = 0 then (acc) else begin
  3048. let vfloat = alloc_var (gen.gmk_internal_name "fn" ("float" ^ string_of_int i)) basic.tfloat in
  3049. let vdyn = alloc_var (gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i)) t_dynamic in
  3050. loop (i - 1) ((vfloat, None) :: (vdyn, None) :: acc)
  3051. end
  3052. in
  3053. loop i []
  3054. in
  3055. let args_real_to_func args =
  3056. let arity = List.length args in
  3057. if arity >= max_arity then
  3058. [ alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic), None ]
  3059. else func_args_i arity
  3060. in
  3061. let func_sig_i i =
  3062. let rec loop i acc =
  3063. if i = 0 then acc else begin
  3064. let vfloat = gen.gmk_internal_name "fn" ("float" ^ string_of_int i) in
  3065. let vdyn = gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i) in
  3066. loop (i - 1) ( (vfloat,false,basic.tfloat) :: (vdyn,false,t_dynamic) :: acc )
  3067. end
  3068. in
  3069. loop i []
  3070. in
  3071. let args_real_to_func_sig args =
  3072. let arity = List.length args in
  3073. if arity >= max_arity then
  3074. [gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic]
  3075. else begin
  3076. func_sig_i arity
  3077. end
  3078. in
  3079. let rettype_real_to_func t = match run_follow gen t with
  3080. | TType({ t_path = [],"Null" }, _) ->
  3081. 0,t_dynamic
  3082. | _ when like_float t && not (like_i64 t) ->
  3083. (1, basic.tfloat)
  3084. | _ ->
  3085. (0, t_dynamic)
  3086. in
  3087. let args_real_to_func_call el (pos:Ast.pos) =
  3088. if List.length el >= max_arity then
  3089. [{ eexpr = TArrayDecl el; etype = basic.tarray t_dynamic; epos = pos }]
  3090. else begin
  3091. List.fold_left (fun acc e ->
  3092. if like_float (gen.greal_type e.etype) && not (like_i64 (gen.greal_type e.etype)) then
  3093. ( e :: undefined e.epos :: acc )
  3094. else
  3095. ( null basic.tfloat e.epos :: e :: acc )
  3096. ) ([]) (List.rev el)
  3097. end
  3098. in
  3099. let const_type c def =
  3100. match c with
  3101. | TString _ -> basic.tstring | TInt _ -> basic.tint
  3102. | TFloat _ -> basic.tfloat | TBool _ -> basic.tbool
  3103. | _ -> def
  3104. in
  3105. let get_args_func args changed_args pos =
  3106. let arity = List.length args in
  3107. let mk_const const elocal t =
  3108. match const with
  3109. | None -> mk_cast t elocal
  3110. | Some const ->
  3111. { eexpr = TIf(
  3112. { elocal with eexpr = TBinop(Ast.OpEq, elocal, null elocal.etype elocal.epos); etype = basic.tbool },
  3113. { elocal with eexpr = TConst(const); etype = const_type const t },
  3114. Some ( mk_cast t elocal )
  3115. ); etype = t; epos = elocal.epos }
  3116. in
  3117. if arity >= max_arity then begin
  3118. let varray = match changed_args with | [v,_] -> v | _ -> assert false in
  3119. let varray_local = mk_local varray pos in
  3120. let mk_varray i = { eexpr = TArray(varray_local, { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }); etype = t_dynamic; epos = pos } in
  3121. snd (List.fold_left (fun (count,acc) (v,const) ->
  3122. (count + 1,
  3123. {
  3124. eexpr = TVar(v, Some(mk_const const ( mk_varray count ) v.v_type));
  3125. etype = basic.tvoid;
  3126. epos = pos;
  3127. } :: acc)
  3128. ) (0,[]) args)
  3129. end else begin
  3130. let _, dyn_args, float_args = List.fold_left (fun (count,fargs, dargs) arg ->
  3131. if count land 1 = 0 then
  3132. (count + 1, fargs, arg :: dargs)
  3133. else
  3134. (count + 1, arg :: fargs, dargs)
  3135. ) (1,[],[]) (List.rev changed_args) in
  3136. let rec loop acc args fargs dargs =
  3137. match args, fargs, dargs with
  3138. | [], [], [] -> acc
  3139. | (v,const) :: args, (vf,_) :: fargs, (vd,_) :: dargs ->
  3140. let acc = { eexpr = TVar(v, Some(
  3141. {
  3142. eexpr = TIf(
  3143. { eexpr = TBinop(Ast.OpEq, mk_local vd pos, undefined pos); etype = basic.tbool; epos = pos },
  3144. mk_cast v.v_type (mk_local vf pos),
  3145. Some ( mk_const const (mk_local vd pos) v.v_type )
  3146. );
  3147. etype = v.v_type;
  3148. epos = pos
  3149. } )); etype = basic.tvoid; epos = pos } :: acc in
  3150. loop acc args fargs dargs
  3151. | _ -> assert false
  3152. in
  3153. loop [] args float_args dyn_args
  3154. end
  3155. in
  3156. let closure_to_classfield tfunc old_sig pos =
  3157. (* change function signature *)
  3158. let old_args = tfunc.tf_args in
  3159. let changed_args = args_real_to_func old_args in
  3160. (*
  3161. FIXME properly handle int64 cases, which will break here (because of inference to int)
  3162. UPDATE: the fix will be that Int64 won't be a typedef to Float/Int
  3163. *)
  3164. let changed_sig, arity, type_number, changed_sig_ret, is_void, is_dynamic_func = match follow old_sig with
  3165. | TFun(_sig, ret) ->
  3166. let type_n, ret_t = rettype_real_to_func ret in
  3167. let arity = List.length _sig in
  3168. let is_dynamic_func = arity >= max_arity in
  3169. let ret_t = if is_dynamic_func then t_dynamic else ret_t in
  3170. (TFun(args_real_to_func_sig _sig, ret_t), arity, type_n, ret_t, is_void ret, is_dynamic_func)
  3171. | _ -> (print_endline (s_type (print_context()) (follow old_sig) )); assert false
  3172. in
  3173. let tf_expr = if is_void then begin
  3174. let rec map e =
  3175. match e.eexpr with
  3176. | TReturn None -> { e with eexpr = TReturn (Some (null t_dynamic e.epos)) }
  3177. | _ -> Type.map_expr map e
  3178. in
  3179. let e = mk_block (map tfunc.tf_expr) in
  3180. match e.eexpr with
  3181. | TBlock(bl) ->
  3182. { e with eexpr = TBlock(bl @ [{ eexpr = TReturn (Some (null t_dynamic e.epos)); etype = t_dynamic; epos = e.epos }]) }
  3183. | _ -> assert false
  3184. end else tfunc.tf_expr in
  3185. let changed_sig_ret = if is_dynamic_func then t_dynamic else changed_sig_ret in
  3186. (* get real arguments on top of function body *)
  3187. let get_args = get_args_func tfunc.tf_args changed_args pos in
  3188. (*
  3189. FIXME HACK: in order to be able to run the filters that have already ran for this piece of code,
  3190. we will cheat and run it as if it was the whole code
  3191. We could just make ClosuresToClass run before TArrayTransform, but we cannot because of the
  3192. dependency between ClosuresToClass (after DynamicFieldAccess, and before TArrayTransform)
  3193. maybe a way to solve this would be to add an "until" field to run_from
  3194. *)
  3195. let real_get_args = gen.gexpr_filters#run_f { eexpr = TBlock(get_args); etype = basic.tvoid; epos = pos } in
  3196. let func_expr = Type.concat real_get_args tf_expr in
  3197. (* set invoke function *)
  3198. (* todo properly abstract how naming for invoke is made *)
  3199. let invoke_name = if is_dynamic_func then "invokeDynamic" else ("invoke" ^ (string_of_int arity) ^ (if type_number = 0 then "_o" else "_f")) in
  3200. let invoke_name = gen.gmk_internal_name "hx" invoke_name in
  3201. let invoke_field = mk_class_field invoke_name changed_sig false func_expr.epos (Method(MethNormal)) [] in
  3202. let invoke_fun =
  3203. {
  3204. eexpr = TFunction(
  3205. {
  3206. tf_args = changed_args;
  3207. tf_type = changed_sig_ret;
  3208. tf_expr = func_expr;
  3209. });
  3210. etype = changed_sig;
  3211. epos = func_expr.epos;
  3212. } in
  3213. invoke_field.cf_expr <- Some(invoke_fun);
  3214. (invoke_field, [
  3215. { eexpr = TConst(TInt( Int32.of_int arity )); etype = gen.gcon.basic.tint; epos = pos };
  3216. { eexpr = TConst(TInt( Int32.of_int type_number )); etype = gen.gcon.basic.tint; epos = pos };
  3217. ])
  3218. in
  3219. let dynamic_fun_call call_expr =
  3220. let tc, params = match call_expr.eexpr with
  3221. | TCall(tc, params) -> (tc, params)
  3222. | _ -> assert false
  3223. in
  3224. let ct = gen.greal_type call_expr.etype in
  3225. let postfix, ret_t =
  3226. if like_float ct && not (like_i64 ct) then
  3227. "_f", gen.gcon.basic.tfloat
  3228. else
  3229. "_o", t_dynamic
  3230. in
  3231. let params_len = List.length params in
  3232. let ret_t = if params_len >= max_arity then t_dynamic else ret_t in
  3233. let invoke_fun = if params_len >= max_arity then "invokeDynamic" else "invoke" ^ (string_of_int params_len) ^ postfix in
  3234. let invoke_fun = gen.gmk_internal_name "hx" invoke_fun in
  3235. let fun_t = match follow tc.etype with
  3236. | TFun(_sig, _) ->
  3237. TFun(args_real_to_func_sig _sig, ret_t)
  3238. | _ ->
  3239. let i = ref 0 in
  3240. let _sig = List.map (fun p -> let name = "arg" ^ (string_of_int !i) in incr i; (name,false,p.etype) ) params in
  3241. TFun(args_real_to_func_sig _sig, ret_t)
  3242. in
  3243. let may_cast = match follow call_expr.etype with
  3244. | TAbstract ({ a_path = ([], "Void") },[]) -> (fun e -> e)
  3245. | _ -> mk_cast call_expr.etype
  3246. in
  3247. may_cast
  3248. {
  3249. eexpr = TCall(
  3250. { (mk_field_access gen { tc with etype = gen.greal_type tc.etype } invoke_fun tc.epos) with etype = fun_t },
  3251. args_real_to_func_call params call_expr.epos
  3252. );
  3253. etype = ret_t;
  3254. epos = call_expr.epos
  3255. }
  3256. in
  3257. let iname is_function i is_float =
  3258. let postfix = if is_float then "_f" else "_o" in
  3259. gen.gmk_internal_name "hx" ("invoke" ^ (if not is_function then "Field" else "") ^ string_of_int i) ^ postfix
  3260. in
  3261. let map_base_classfields cl is_function map_fn =
  3262. let pos = cl.cl_pos in
  3263. let this_t = TInst(cl,List.map snd cl.cl_params) in
  3264. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  3265. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  3266. let mk_invoke_i i is_float =
  3267. let cf = mk_class_field (iname is_function i is_float) (TFun(func_sig_i i, if is_float then basic.tfloat else t_dynamic)) false pos (Method MethNormal) [] in
  3268. cf
  3269. in
  3270. let type_name = gen.gmk_internal_name "fn" "type" in
  3271. let dynamic_arg = alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic) in
  3272. let mk_invoke_complete_i i is_float =
  3273. (* let arity = i in *)
  3274. let args = func_args_i i in
  3275. (* api fn *)
  3276. (* only cast if needed *)
  3277. let mk_cast tto efrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type efrom.etype) efrom in
  3278. let api i t const =
  3279. let vf, _ = List.nth args (i * 2) in
  3280. let vo, _ = List.nth args (i * 2 + 1) in
  3281. let needs_cast, is_float = match t, like_float t && not (like_i64 t) with
  3282. | TAbstract({ a_path = ([], "Float") },[]), _ -> false, true
  3283. | _, true -> true, true
  3284. | _ -> false,false
  3285. in
  3286. let olocal = mk_local vo pos in
  3287. let flocal = mk_local vf pos in
  3288. let get_from_obj e = match const with
  3289. | None -> mk_cast t e
  3290. | Some tc ->
  3291. {
  3292. eexpr = TIf(
  3293. { eexpr = TBinop(Ast.OpEq, olocal, null t_dynamic pos); etype = basic.tbool; epos = pos } ,
  3294. { eexpr = TConst(tc); etype = t; epos = pos },
  3295. Some (mk_cast t e)
  3296. );
  3297. etype = t;
  3298. epos = pos;
  3299. }
  3300. in
  3301. {
  3302. eexpr = TIf(
  3303. { eexpr = TBinop(Ast.OpEq, olocal, undefined pos); etype = basic.tbool; epos = pos },
  3304. (if needs_cast then mk_cast t flocal else flocal),
  3305. Some ( get_from_obj olocal )
  3306. );
  3307. etype = t;
  3308. epos = pos
  3309. }
  3310. in
  3311. (* end of api fn *)
  3312. let ret = if is_float then basic.tfloat else t_dynamic in
  3313. let added_args, fn_expr = map_fn i ret (List.map fst args) api in
  3314. let args = added_args @ args in
  3315. let t = TFun(fun_args args, ret) in
  3316. let tfunction =
  3317. {
  3318. eexpr = TFunction({
  3319. tf_args = args;
  3320. tf_type = ret;
  3321. tf_expr =
  3322. mk_block fn_expr
  3323. });
  3324. etype = t;
  3325. epos = pos;
  3326. }
  3327. in
  3328. let cf = mk_invoke_i i is_float in
  3329. cf.cf_expr <- Some tfunction;
  3330. cf
  3331. in
  3332. let rec loop i cfs =
  3333. if i < 0 then cfs else begin
  3334. (*let mk_invoke_complete_i i is_float =*)
  3335. (mk_invoke_complete_i i false) :: (mk_invoke_complete_i i true) :: (loop (i-1) cfs)
  3336. end
  3337. in
  3338. let cfs = loop max_arity [] in
  3339. let added_s_args, switch =
  3340. let api i t const =
  3341. match i with
  3342. | -1 ->
  3343. mk_local dynamic_arg pos
  3344. | _ ->
  3345. mk_cast t {
  3346. eexpr = TArray(
  3347. mk_local dynamic_arg pos,
  3348. { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos });
  3349. etype = t;
  3350. epos = pos;
  3351. }
  3352. in
  3353. map_fn (-1) t_dynamic [dynamic_arg] api
  3354. in
  3355. let args = added_s_args @ [dynamic_arg, None] in
  3356. let dyn_t = TFun(fun_args args, t_dynamic) in
  3357. let dyn_cf = mk_class_field (gen.gmk_internal_name "hx" "invokeDynamic") dyn_t false pos (Method MethNormal) [] in
  3358. dyn_cf.cf_expr <-
  3359. Some {
  3360. eexpr = TFunction({
  3361. tf_args = args;
  3362. tf_type = t_dynamic;
  3363. tf_expr = mk_block switch
  3364. });
  3365. etype = dyn_t;
  3366. epos = pos;
  3367. };
  3368. let additional_cfs = if is_function then begin
  3369. let new_t = TFun(["arity", false, basic.tint; "type", false, basic.tint],basic.tvoid) in
  3370. let new_cf = mk_class_field "new" (new_t) true pos (Method MethNormal) [] in
  3371. let v_arity, v_type = alloc_var "arity" basic.tint, alloc_var "type" basic.tint in
  3372. let mk_assign v field = { eexpr = TBinop(Ast.OpAssign, mk_this field v.v_type, mk_local v pos); etype = v.v_type; epos = pos } in
  3373. let arity_name = gen.gmk_internal_name "hx" "arity" in
  3374. new_cf.cf_expr <-
  3375. Some {
  3376. eexpr = TFunction({
  3377. tf_args = [v_arity, None; v_type, None];
  3378. tf_type = basic.tvoid;
  3379. tf_expr =
  3380. {
  3381. eexpr = TBlock([
  3382. mk_assign v_type type_name;
  3383. mk_assign v_arity arity_name
  3384. ]);
  3385. etype = basic.tvoid;
  3386. epos = pos;
  3387. }
  3388. });
  3389. etype = new_t;
  3390. epos = pos;
  3391. }
  3392. ;
  3393. [
  3394. new_cf;
  3395. mk_class_field type_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  3396. mk_class_field arity_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  3397. ]
  3398. end else [] in
  3399. dyn_cf :: (additional_cfs @ cfs)
  3400. in
  3401. (* maybe another param for prefix *)
  3402. let get_base_classfields_for cl is_function mk_additional_args =
  3403. let pos = cl.cl_pos in
  3404. let this_t = TInst(cl,List.map snd cl.cl_params) in
  3405. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  3406. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  3407. let rec mk_dyn_call arity api =
  3408. let zero = { eexpr = TConst(TFloat("0.0")); etype = basic.tfloat; epos = pos } in
  3409. let rec loop i acc =
  3410. if i = 0 then acc else begin
  3411. let arr = api (i-1) t_dynamic None in
  3412. loop (i - 1) (zero :: arr :: acc)
  3413. end
  3414. in
  3415. loop arity ([])
  3416. in
  3417. let mk_invoke_switch i (api:(int->t->tconstant option->texpr)) =
  3418. let t = TFun(func_sig_i i,t_dynamic) in
  3419. (* case i: return this.invokeX_o(0, 0, 0, 0, 0, ... arg[0], args[1]....); *)
  3420. ( [{ eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }],
  3421. {
  3422. eexpr = TReturn(Some( {
  3423. eexpr = TCall(mk_this (iname is_function i false) t, mk_dyn_call i api);
  3424. etype = t_dynamic;
  3425. epos = pos;
  3426. } ));
  3427. etype = t_dynamic;
  3428. epos = pos;
  3429. } )
  3430. in
  3431. let cl_t = TInst(cl,List.map snd cl.cl_params) in
  3432. let this = { eexpr = TConst(TThis); etype = cl_t; epos = pos } in
  3433. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  3434. let mk_int i = { eexpr = TConst(TInt ( Int32.of_int i)); etype = basic.tint; epos = pos } in
  3435. let mk_string s = { eexpr = TConst(TString s); etype = basic.tstring; epos = pos } in
  3436. (*
  3437. if it is the Function class, the base class fields will be
  3438. * hx::invokeX_d|o (where X is from 0 to max_arity) (args)
  3439. {
  3440. if (this.type == 0|1) return invokeX_o|d(args); else throw "Invalid number of arguments."
  3441. }
  3442. hx::invokeDynamic, which will work in the same way
  3443. new(arity, type)
  3444. {
  3445. if (type != 0 && type != 1) throw "Invalid type";
  3446. this.arity = arity;
  3447. this.type = type;
  3448. }
  3449. *)
  3450. let type_name = gen.gmk_internal_name "fn" "type" in
  3451. let mk_expr i is_float vars =
  3452. let name = if is_function then "invoke" else "invokeField" in
  3453. let look_ahead = alloc_var "lookAhead" basic.tbool in
  3454. let add_args = if not is_function then mk_additional_args() else [] in
  3455. let vars = if not is_function then (List.map fst add_args) @ (look_ahead :: vars) else vars in
  3456. let call_expr =
  3457. let call_t = TFun(List.map (fun v -> (v.v_name, false, v.v_type)) vars, if is_float then t_dynamic else basic.tfloat) in
  3458. {
  3459. eexpr = TCall(mk_this (gen.gmk_internal_name "hx" (name ^ (string_of_int i) ^ (if is_float then "_o" else "_f"))) call_t, List.map (fun v -> if v.v_id = look_ahead.v_id then ( { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos } ) else mk_local v pos) vars );
  3460. etype = if is_float then t_dynamic else basic.tfloat;
  3461. epos = pos
  3462. }
  3463. in
  3464. (*let call_expr = if is_float then mk_cast basic.tfloat call_expr else call_expr in*)
  3465. let if_cond = if is_function then
  3466. { eexpr=TBinop(Ast.OpNotEq, mk_this type_name basic.tint, mk_int (if is_float then 0 else 1) ); etype = basic.tbool; epos = pos }
  3467. else
  3468. mk_local look_ahead pos
  3469. in
  3470. let if_expr = if is_function then
  3471. {
  3472. eexpr = TIf(if_cond,
  3473. { eexpr = TThrow(mk_string "Wrong number of arguments"); etype = basic.tstring; epos = pos },
  3474. Some( { eexpr = TReturn( Some( call_expr ) ); etype = call_expr.etype; epos = pos } )
  3475. );
  3476. etype = t_dynamic;
  3477. epos = pos;
  3478. }
  3479. else
  3480. {
  3481. eexpr = TIf(if_cond,
  3482. { eexpr = TReturn( Some( call_expr ) ); etype = call_expr.etype; epos = pos },
  3483. Some( { eexpr = TThrow(mk_string "Field not found or wrong number of arguments"); etype = basic.tstring; epos = pos } )
  3484. );
  3485. etype = t_dynamic;
  3486. epos = pos;
  3487. }
  3488. in
  3489. let args = if not is_function then (mk_additional_args()) @ [look_ahead, None] else [] in
  3490. (args, if_expr)
  3491. in
  3492. let arities_processed = Hashtbl.create 10 in
  3493. let max_arity = ref 0 in
  3494. let rec loop_cases api arity acc =
  3495. if arity < 0 then acc else
  3496. loop_cases api (arity - 1) (mk_invoke_switch arity api :: acc)
  3497. in
  3498. (* let rec loop goes here *)
  3499. let map_fn cur_arity fun_ret_type vars (api:(int->t->tconstant option->texpr)) =
  3500. let is_float = like_float fun_ret_type && not (like_i64 fun_ret_type) in
  3501. match cur_arity with
  3502. | -1 ->
  3503. let dynargs = api (-1) (t_dynamic) None in
  3504. let switch_cond = mk_field_access gen dynargs "length" pos in
  3505. let switch_cond = {
  3506. eexpr = TIf(
  3507. { eexpr = TBinop(Ast.OpEq, dynargs, null dynargs.etype pos); etype = basic.tbool; epos = pos; },
  3508. { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos },
  3509. Some switch_cond);
  3510. etype = basic.tint;
  3511. epos = pos;
  3512. } in
  3513. let switch =
  3514. {
  3515. eexpr = TSwitch( switch_cond,
  3516. loop_cases api !max_arity [],
  3517. Some({ eexpr = TThrow(mk_string "Too many arguments"); etype = basic.tvoid; epos = pos; }) );
  3518. etype = basic.tvoid;
  3519. epos = pos;
  3520. } in
  3521. ( (if not is_function then mk_additional_args () else []), switch )
  3522. | _ ->
  3523. if not (Hashtbl.mem arities_processed cur_arity) then begin
  3524. Hashtbl.add arities_processed cur_arity true;
  3525. if cur_arity > !max_arity then max_arity := cur_arity
  3526. end;
  3527. mk_expr cur_arity is_float vars
  3528. in
  3529. map_base_classfields cl is_function map_fn
  3530. in
  3531. let initialize_base_class cl =
  3532. ()
  3533. in
  3534. {
  3535. fgen = gen;
  3536. func_class = null_class;
  3537. closure_to_classfield = closure_to_classfield;
  3538. dynamic_fun_call = dynamic_fun_call;
  3539. (*
  3540. called once so the implementation can make one of a time initializations in the base class
  3541. for all functions
  3542. *)
  3543. initialize_base_class = initialize_base_class;
  3544. (*
  3545. Base classfields are the class fields for the abstract implementation of either the Function implementation,
  3546. or the invokeField implementation for the classes
  3547. They will either try to call the right function or will fail with
  3548. (tclass - subject (so we know the type of this)) -> is_function_base -> list of the abstract implementation class fields
  3549. *)
  3550. get_base_classfields_for = get_base_classfields_for;
  3551. map_base_classfields = map_base_classfields;
  3552. (*
  3553. for now we won't deal with the closures.
  3554. They can be dealt with the module ReflectionCFs,
  3555. or a custom implementation
  3556. *)
  3557. transform_closure = (fun tclosure texpr str -> tclosure);
  3558. }
  3559. end;;
  3560. end;;
  3561. (* ******************************************* *)
  3562. (* Type Parameters *)
  3563. (* ******************************************* *)
  3564. (*
  3565. This module will handle type parameters. There are lots of changes we need to do to correctly support type parameters:
  3566. traverse will:
  3567. V Detect when parameterized function calls are made
  3568. * Detect when a parameterized class instance is being cast to another parameter
  3569. * Change new<> parameterized function calls
  3570. *
  3571. extras:
  3572. * On languages that support "real" type parameters, a Cast function is provided that will convert from a <Dynamic> to the requested type.
  3573. This cast will call createEmpty with the correct type, and then set each variable to the new form. Some types will be handled specially, namely the Native Array.
  3574. Other implementations may be delegated to the runtime.
  3575. * parameterized classes will implement a new interface (with only a Cast<> function added to it), so we can access the <Dynamic> type parameter for them. Also any reference to <Dynamic> will be replaced by a reference to this interface. (also on TTypeExpr - Std.is())
  3576. * Type parameter renaming to avoid name clash
  3577. * Detect type parameter casting and call Cast<> instead
  3578. for java:
  3579. * for specially assigned classes, parameters will be replaced by _d and _i versions of parameterized functions. This will only work for parameterized classes, not functions.
  3580. dependencies:
  3581. must run after casts are detected. This will be ensured at CastDetect module.
  3582. *)
  3583. module TypeParams =
  3584. struct
  3585. let name = "type_params"
  3586. let priority = max_dep -. 20.
  3587. let rec deep_follow gen t = match run_follow gen t with
  3588. | TInst(c,tl) ->
  3589. TInst(c,List.map (deep_follow gen) tl)
  3590. | TEnum(e,tl) ->
  3591. TEnum(e,List.map (deep_follow gen) tl)
  3592. | TAbstract(a,tl) ->
  3593. TAbstract(a,List.map (deep_follow gen) tl)
  3594. | TType(t,tl) ->
  3595. TType(t,List.map (deep_follow gen) tl)
  3596. | TFun(args,ret) ->
  3597. TFun(List.map (fun (n,o,t) -> n,o,deep_follow gen t) args, deep_follow gen ret)
  3598. | t -> t
  3599. (* this function will receive the original function argument, the applied function argument and the original function parameters. *)
  3600. (* from this info, it will infer the applied tparams for the function *)
  3601. (* this function is used by CastDetection module *)
  3602. let infer_params gen pos (original_args:((string * bool * t) list * t)) (applied_args:((string * bool * t) list * t)) (params:(string * t) list) calls_parameters_explicitly : tparams =
  3603. match params with
  3604. | [] -> []
  3605. | _ ->
  3606. let args_list args = (if not calls_parameters_explicitly then t_dynamic else snd args) :: (List.map (fun (n,o,t) -> t) (fst args)) in
  3607. let monos = List.map (fun _ -> mk_mono()) params in
  3608. let original = args_list (get_fun (apply_params params monos (TFun(fst original_args,snd original_args)))) in
  3609. let applied = args_list applied_args in
  3610. (try
  3611. List.iter2 (fun a o ->
  3612. let o = deep_follow gen o in
  3613. let a = deep_follow gen a in
  3614. unify a o
  3615. (* type_eq EqStrict a o *)
  3616. ) applied original
  3617. (* unify applied original *)
  3618. with | Unify_error el ->
  3619. (* List.iter (fun el -> gen.gcon.warning (Typecore.unify_error_msg (print_context()) el) pos) el; *)
  3620. gen.gcon.warning ("This expression may be invalid") pos
  3621. | Invalid_argument("List.map2") ->
  3622. gen.gcon.warning ("This expression may be invalid") pos
  3623. );
  3624. List.map (fun t ->
  3625. match follow t with
  3626. | TMono _ -> t_empty
  3627. | t -> t
  3628. ) monos
  3629. (* ******************************************* *)
  3630. (* Real Type Parameters Module *)
  3631. (* ******************************************* *)
  3632. (*
  3633. This submodule is by now specially made for the .NET platform. There might be other targets that will
  3634. make use of this, but it IS very specific.
  3635. On the .NET platform, generics are real specialized classes that are JIT compiled. For this reason, we cannot
  3636. cast from one type parameter to another. Also there is no common type for the type parameters, so for example
  3637. an instance of type Array<Int> will return false for instance is Array<object> .
  3638. So we need to:
  3639. 1. create a common interface (without type parameters) (e.g. "Array") which will only contain a __Cast<> function, which will cast from one type into another
  3640. 2. Implement the __Cast function. This part is a little hard, as we must identify all type parameter-dependent fields contained in the class and convert them.
  3641. In most cases the conversion will just be to call .__Cast<>() on the instances, or just a simple cast. But when the instance is a @:nativegen type, there will be no .__Cast
  3642. function, and we will need to deal with this case either at compile-time (added handlers - specially for NativeArray), or at runtime (adding new runtime handlers)
  3643. 3. traverse the AST looking for casts involving type parameters, and replace them with .__Cast<>() calls. If type is @:nativegen, throw a warning. If really casting from one type parameter to another on a @:nativegen context, throw an error.
  3644. special literals:
  3645. it will use the special literal __typehandle__ that the target must implement in order to run this. This literal is a way to get the typehandle of e.g. the type parameters,
  3646. so we can compare them. In C# it's the equivalent of typeof(T).TypeHandle (TypeHandle compare is faster than System.Type.Equals())
  3647. dependencies:
  3648. (module filter) Interface creation must run AFTER enums are converted into classes, otherwise there is no way to tell parameterized enums to implement an interface
  3649. Must run AFTER CastDetect. This will be ensured per CastDetect
  3650. *)
  3651. module RealTypeParams =
  3652. struct
  3653. let name = "real_type_params"
  3654. let priority = priority
  3655. let cast_field_name = "cast"
  3656. let rec has_type_params t =
  3657. match follow t with
  3658. | TInst( { cl_kind = KTypeParameter _ }, _) -> true
  3659. | TAbstract(_, params)
  3660. | TEnum(_, params)
  3661. | TInst(_, params) -> List.exists (fun t -> has_type_params t) params
  3662. | TFun(args,ret) ->
  3663. List.exists (fun (n,o,t) -> has_type_params t) args || has_type_params ret
  3664. | _ -> false
  3665. let rec follow_all_md md =
  3666. let t = match md with
  3667. | TClassDecl { cl_kind = KAbstractImpl a } ->
  3668. TAbstract(a, List.map snd a.a_params)
  3669. | TClassDecl c ->
  3670. TInst(c, List.map snd c.cl_params)
  3671. | TEnumDecl e ->
  3672. TEnum(e, List.map snd e.e_params)
  3673. | TTypeDecl t ->
  3674. TType(t, List.map snd t.t_params)
  3675. | TAbstractDecl a ->
  3676. TAbstract(a, List.map snd a.a_params)
  3677. in
  3678. Abstract.follow_with_abstracts t
  3679. let rec is_hxgeneric md =
  3680. match md with
  3681. | TClassDecl { cl_kind = KAbstractImpl a } ->
  3682. is_hxgeneric (TAbstractDecl a)
  3683. | TClassDecl(cl) ->
  3684. not (Meta.has Meta.NativeGeneric cl.cl_meta)
  3685. | TEnumDecl(e) ->
  3686. not (Meta.has Meta.NativeGeneric e.e_meta)
  3687. | TAbstractDecl(a) when Meta.has Meta.NativeGeneric a.a_meta ->
  3688. not (Meta.has Meta.NativeGeneric a.a_meta)
  3689. | md -> match follow_all_md md with
  3690. | TInst(cl,_) -> is_hxgeneric (TClassDecl cl)
  3691. | TEnum(e,_) -> is_hxgeneric (TEnumDecl e)
  3692. | TAbstract(a,_) -> not (Meta.has Meta.NativeGeneric a.a_meta)
  3693. | _ -> true
  3694. let rec set_hxgeneric gen mds isfirst md =
  3695. let path = t_path md in
  3696. if List.exists (fun m -> path = t_path m) mds then begin
  3697. if isfirst then
  3698. None (* we still can't determine *)
  3699. else
  3700. Some true (* if we're in second pass and still can't determine, it's because it can be hxgeneric *)
  3701. end else begin
  3702. let has_unresolved = ref false in
  3703. let is_false v =
  3704. match v with
  3705. | Some false -> true
  3706. | None -> has_unresolved := true; false
  3707. | Some true -> false
  3708. in
  3709. let mds = md :: mds in
  3710. match md with
  3711. | TClassDecl(cl) ->
  3712. (* first see if any meta is present (already processed) *)
  3713. if Meta.has Meta.NativeGeneric cl.cl_meta then
  3714. Some false
  3715. else if Meta.has Meta.HaxeGeneric cl.cl_meta then
  3716. Some true
  3717. else if cl.cl_params = [] && is_hxgen md then
  3718. (cl.cl_meta <- (Meta.HaxeGeneric,[],cl.cl_pos) :: cl.cl_meta;
  3719. Some true)
  3720. else if cl.cl_params = [] then
  3721. (cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3722. Some false)
  3723. else if not (is_hxgen md) then
  3724. (cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3725. Some false)
  3726. else begin
  3727. (*
  3728. if it's not present, see if any superclass is nativegeneric.
  3729. nativegeneric is inherited, while hxgeneric can be later changed to nativegeneric
  3730. *)
  3731. (* on the first pass, our job is to find any evidence that makes it not be hxgeneric. Otherwise it will be hxgeneric *)
  3732. match cl.cl_super with
  3733. | Some (c,_) when is_false (set_hxgeneric gen mds isfirst (TClassDecl c)) ->
  3734. cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3735. Some false
  3736. | _ ->
  3737. (* see if it's a generic class *)
  3738. match cl.cl_params with
  3739. | [] ->
  3740. (* if it's not, then it will follow hxgen *)
  3741. if is_hxgen (TClassDecl cl) then
  3742. cl.cl_meta <- (Meta.HaxeGeneric, [], cl.cl_pos) :: cl.cl_meta
  3743. else
  3744. cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3745. Some true
  3746. | _ ->
  3747. (* if it is, loop through all fields + statics and look for non-hxgeneric
  3748. generic classes that have KTypeParameter as params *)
  3749. let rec loop cfs =
  3750. match cfs with
  3751. | [] -> false
  3752. | cf :: cfs ->
  3753. let t = follow (gen.greal_type cf.cf_type) in
  3754. match t with
  3755. | TInst( { cl_kind = KTypeParameter _ }, _ ) -> loop cfs
  3756. | TInst(cl,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TClassDecl cl)) ->
  3757. if not (Hashtbl.mem gen.gtparam_cast cl.cl_path) then true else loop cfs
  3758. | TEnum(e,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TEnumDecl e)) ->
  3759. if not (Hashtbl.mem gen.gtparam_cast e.e_path) then true else loop cfs
  3760. | _ -> loop cfs (* TAbstracts / Dynamics can't be generic *)
  3761. in
  3762. if loop cl.cl_ordered_fields then begin
  3763. cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3764. Some false
  3765. end else if isfirst && !has_unresolved then
  3766. None
  3767. else begin
  3768. cl.cl_meta <- (Meta.HaxeGeneric, [], cl.cl_pos) :: cl.cl_meta;
  3769. Some true
  3770. end
  3771. end
  3772. | TEnumDecl e ->
  3773. if Meta.has Meta.NativeGeneric e.e_meta then
  3774. Some false
  3775. else if Meta.has Meta.HaxeGeneric e.e_meta then
  3776. Some true
  3777. else if not (is_hxgen (TEnumDecl e)) then begin
  3778. e.e_meta <- (Meta.NativeGeneric, [], e.e_pos) :: e.e_meta;
  3779. Some false
  3780. end else begin
  3781. (* if enum is not generic, then it's hxgeneric *)
  3782. match e.e_params with
  3783. | [] ->
  3784. e.e_meta <- (Meta.HaxeGeneric, [], e.e_pos) :: e.e_meta;
  3785. Some true
  3786. | _ ->
  3787. let rec loop efs =
  3788. match efs with
  3789. | [] -> false
  3790. | ef :: efs ->
  3791. let t = follow (gen.greal_type ef.ef_type) in
  3792. match t with
  3793. | TFun(args, _) ->
  3794. if List.exists (fun (n,o,t) ->
  3795. let t = follow t in
  3796. match t with
  3797. | TInst( { cl_kind = KTypeParameter _ }, _ ) ->
  3798. false
  3799. | TInst(cl,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TClassDecl cl)) ->
  3800. not (Hashtbl.mem gen.gtparam_cast cl.cl_path)
  3801. | TEnum(e,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TEnumDecl e)) ->
  3802. not (Hashtbl.mem gen.gtparam_cast e.e_path)
  3803. | _ -> false
  3804. ) args then
  3805. true
  3806. else
  3807. loop efs
  3808. | _ -> loop efs
  3809. in
  3810. let efs = PMap.fold (fun ef acc -> ef :: acc) e.e_constrs [] in
  3811. if loop efs then begin
  3812. e.e_meta <- (Meta.NativeGeneric, [], e.e_pos) :: e.e_meta;
  3813. Some false
  3814. end else if isfirst && !has_unresolved then
  3815. None
  3816. else begin
  3817. e.e_meta <- (Meta.HaxeGeneric, [], e.e_pos) :: e.e_meta;
  3818. Some true
  3819. end
  3820. end
  3821. | _ -> assert false
  3822. end
  3823. let set_hxgeneric gen md =
  3824. let ret = match md with
  3825. | TClassDecl { cl_kind = KAbstractImpl a } -> (match follow_all_md md with
  3826. | (TInst _ | TEnum _ as t) -> (
  3827. let md = match t with
  3828. | TInst(cl,_) -> TClassDecl cl
  3829. | TEnum(e,_) -> TEnumDecl e
  3830. | _ -> assert false
  3831. in
  3832. let ret = set_hxgeneric gen [] true md in
  3833. if ret = None then get (set_hxgeneric gen [] false md) else get ret)
  3834. | TAbstract(a,_) -> true
  3835. | _ -> true)
  3836. | _ -> match set_hxgeneric gen [] true md with
  3837. | None ->
  3838. get (set_hxgeneric gen [] false md)
  3839. | Some v ->
  3840. v
  3841. in
  3842. if not ret then begin
  3843. match md with
  3844. | TClassDecl c ->
  3845. let set_hxgeneric (_,param) = match follow param with
  3846. | TInst(c,_) ->
  3847. c.cl_meta <- (Meta.NativeGeneric, [], c.cl_pos) :: c.cl_meta
  3848. | _ -> ()
  3849. in
  3850. List.iter set_hxgeneric c.cl_params;
  3851. let rec handle_field cf =
  3852. List.iter set_hxgeneric cf.cf_params;
  3853. List.iter handle_field cf.cf_overloads
  3854. in
  3855. (match c.cl_kind with
  3856. | KAbstractImpl a ->
  3857. List.iter set_hxgeneric a.a_params;
  3858. | _ -> ());
  3859. List.iter handle_field c.cl_ordered_fields;
  3860. List.iter handle_field c.cl_ordered_statics
  3861. | _ -> ()
  3862. end;
  3863. ret
  3864. let params_has_tparams params =
  3865. List.fold_left (fun acc t -> acc || has_type_params t) false params
  3866. (* ******************************************* *)
  3867. (* RealTypeParamsModf *)
  3868. (* ******************************************* *)
  3869. (*
  3870. This is the module filter of Real Type Parameters. It will traverse through all types and look for hxgeneric classes (only classes).
  3871. When found, a parameterless interface will be created and associated via the "ifaces" Hashtbl to the original class.
  3872. Also a "cast" function will be automatically generated which will handle unsafe downcasts to more specific type parameters (necessary for serialization)
  3873. dependencies:
  3874. Anything that may create hxgeneric classes must run before it.
  3875. Should run before ReflectionCFs (this dependency will be added to ReflectionCFs), so the added interfaces also get to be real IHxObject's
  3876. *)
  3877. module RealTypeParamsModf =
  3878. struct
  3879. let set_only_hxgeneric gen =
  3880. let rec run md =
  3881. match md with
  3882. | TTypeDecl _ | TAbstractDecl _ -> md
  3883. | _ -> ignore (set_hxgeneric gen md); md
  3884. in
  3885. run
  3886. let name = "real_type_params_modf"
  3887. let priority = solve_deps name []
  3888. let rec get_fields gen cl params_cl params_cf acc =
  3889. let fields = List.fold_left (fun acc cf ->
  3890. match follow (gen.greal_type (gen.gfollow#run_f (cf.cf_type))) with
  3891. | TInst(cli, ((_ :: _) as p)) when (not (is_hxgeneric (TClassDecl cli))) && params_has_tparams p ->
  3892. (cf, apply_params cl.cl_params params_cl cf.cf_type, apply_params cl.cl_params params_cf cf.cf_type) :: acc
  3893. | TEnum(e, ((_ :: _) as p)) when not (is_hxgeneric (TEnumDecl e)) && params_has_tparams p ->
  3894. (cf, apply_params cl.cl_params params_cl cf.cf_type, apply_params cl.cl_params params_cf cf.cf_type) :: acc
  3895. | _ -> acc
  3896. ) [] cl.cl_ordered_fields in
  3897. match cl.cl_super with
  3898. | Some(cs, tls) ->
  3899. get_fields gen cs (List.map (apply_params cl.cl_params params_cl) tls) (List.map (apply_params cl.cl_params params_cf) tls) (fields @ acc)
  3900. | None -> (fields @ acc)
  3901. (* overrides all needed cast functions from super classes / interfaces to call the new cast function *)
  3902. let create_stub_casts gen cl cast_cfield =
  3903. (* go through superclasses and interfaces *)
  3904. let p = cl.cl_pos in
  3905. let this = { eexpr = TConst TThis; etype = (TInst(cl, List.map snd cl.cl_params)); epos = p } in
  3906. let rec loop cls tls level reverse_params =
  3907. if (level <> 0 || cls.cl_interface) && tls <> [] && is_hxgeneric (TClassDecl cls) then begin
  3908. let cparams = List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) cls.cl_params in
  3909. let name = String.concat "_" ((fst cls.cl_path) @ [snd cls.cl_path; cast_field_name]) in
  3910. if not (PMap.mem name cl.cl_fields) then begin
  3911. let reverse_params = List.map (apply_params cls.cl_params (List.map snd cparams)) reverse_params in
  3912. let cfield = mk_class_field name (TFun([], t_dynamic)) false cl.cl_pos (Method MethNormal) cparams in
  3913. let field = { eexpr = TField(this, FInstance(cl,List.map snd cl.cl_params, cast_cfield)); etype = apply_params cast_cfield.cf_params reverse_params cast_cfield.cf_type; epos = p } in
  3914. let call =
  3915. {
  3916. eexpr = TCall(field, []);
  3917. etype = t_dynamic;
  3918. epos = p;
  3919. } in
  3920. let call = gen.gparam_func_call call field reverse_params [] in
  3921. let delay () =
  3922. cfield.cf_expr <-
  3923. Some {
  3924. eexpr = TFunction(
  3925. {
  3926. tf_args = [];
  3927. tf_type = t_dynamic;
  3928. tf_expr =
  3929. {
  3930. eexpr = TReturn( Some call );
  3931. etype = t_dynamic;
  3932. epos = p;
  3933. }
  3934. });
  3935. etype = cfield.cf_type;
  3936. epos = p;
  3937. }
  3938. in
  3939. gen.gafter_filters_ended <- delay :: gen.gafter_filters_ended; (* do not let filters alter this expression content *)
  3940. cl.cl_ordered_fields <- cfield :: cl.cl_ordered_fields;
  3941. cl.cl_fields <- PMap.add cfield.cf_name cfield cl.cl_fields;
  3942. if level <> 0 then cl.cl_overrides <- cfield :: cl.cl_overrides
  3943. end
  3944. end;
  3945. let get_reverse super supertl =
  3946. let kv = List.map2 (fun (_,tparam) applied -> (follow applied, follow tparam)) super.cl_params supertl in
  3947. List.map (fun t ->
  3948. try
  3949. List.assq (follow t) kv
  3950. with | Not_found -> t
  3951. ) reverse_params
  3952. in
  3953. (match cls.cl_super with
  3954. | None -> ()
  3955. | Some(super, supertl) ->
  3956. loop super supertl (level + 1) (get_reverse super supertl));
  3957. List.iter (fun (iface, ifacetl) ->
  3958. loop iface ifacetl level (get_reverse iface ifacetl)
  3959. ) cls.cl_implements
  3960. in
  3961. loop cl (List.map snd cl.cl_params) 0 (List.map snd cl.cl_params)
  3962. (*
  3963. Creates a cast classfield, with the desired name
  3964. Will also look for previous cast() definitions and override them, to reflect the current type and fields
  3965. FIXME: this function still doesn't support generics that extend generics, and are cast as one of its subclasses. This needs to be taken care, by
  3966. looking at previous superclasses and whenever a generic class is found, its cast argument must be overriden. the toughest part is to know how to type
  3967. the current type correctly.
  3968. *)
  3969. let create_cast_cfield gen cl name =
  3970. let basic = gen.gcon.basic in
  3971. let cparams = List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) cl.cl_params in
  3972. let cfield = mk_class_field name (TFun([], t_dynamic)) false cl.cl_pos (Method MethNormal) cparams in
  3973. let params = List.map snd cparams in
  3974. let fields = get_fields gen cl (List.map snd cl.cl_params) params [] in
  3975. (* now create the contents of the function *)
  3976. (*
  3977. it will look something like:
  3978. if (typeof(T) == typeof(T2)) return this;
  3979. var new_me = new CurrentClass<T2>(EmptyInstnace);
  3980. for (field in Reflect.fields(this))
  3981. {
  3982. switch(field)
  3983. {
  3984. case "aNativeArray":
  3985. var newArray = new NativeArray(this.aNativeArray.Length);
  3986. default:
  3987. Reflect.setField(new_me, field, Reflect.field(this, field));
  3988. }
  3989. }
  3990. *)
  3991. let new_t = TInst(cl, params) in
  3992. let pos = cl.cl_pos in
  3993. let new_me_var = alloc_var "new_me" new_t in
  3994. let local_new_me = { eexpr = TLocal(new_me_var); etype = new_t; epos = pos } in
  3995. let this = { eexpr = TConst(TThis); etype = (TInst(cl, List.map snd cl.cl_params)); epos = pos } in
  3996. let field_var = alloc_var "field" gen.gcon.basic.tstring in
  3997. let local_field = { eexpr = TLocal(field_var); etype = field_var.v_type; epos = pos } in
  3998. let i_var = alloc_var "i" gen.gcon.basic.tint in
  3999. let local_i = { eexpr = TLocal(i_var); etype = gen.gcon.basic.tint; epos = pos } in
  4000. let incr_i = { eexpr = TUnop(Ast.Increment, Ast.Postfix, local_i); etype = basic.tint; epos = pos } in
  4001. let fields_var = alloc_var "fields" (gen.gcon.basic.tarray gen.gcon.basic.tstring) in
  4002. let local_fields = { eexpr = TLocal(fields_var); etype = (gen.gcon.basic.tarray gen.gcon.basic.tstring); epos = pos } in
  4003. let get_path t =
  4004. match follow t with
  4005. | TInst(cl,_) -> cl.cl_path
  4006. | TEnum(e,_) -> e.e_path
  4007. | TAbstract(a,_) -> a.a_path
  4008. | TMono _
  4009. | TDynamic _ -> ([], "Dynamic")
  4010. | _ -> assert false
  4011. in
  4012. (* this will take all fields that were *)
  4013. let fields_to_cases fields =
  4014. List.map (fun (cf, t_cl, t_cf) ->
  4015. let this_field = { eexpr = TField(this, FInstance(cl, List.map snd cl.cl_params, cf)); etype = t_cl; epos = pos } in
  4016. let expr =
  4017. {
  4018. eexpr = TBinop(OpAssign, { eexpr = TField(local_new_me, FInstance(cl, List.map snd cl.cl_params, cf) ); etype = t_cf; epos = pos },
  4019. try (Hashtbl.find gen.gtparam_cast (get_path t_cf)) this_field t_cf with | Not_found -> (* if not found tparam cast, it shouldn't be a valid hxgeneric *) assert false
  4020. );
  4021. etype = t_cf;
  4022. epos = pos;
  4023. } in
  4024. ([{ eexpr = TConst(TString(cf.cf_name)); etype = gen.gcon.basic.tstring; epos = pos }], expr)
  4025. ) fields
  4026. in
  4027. let mk_typehandle =
  4028. let thandle = alloc_var "__typeof__" t_dynamic in
  4029. (fun cl -> { eexpr = TCall(mk_local thandle pos, [ mk_classtype_access cl pos ]); etype = t_dynamic; epos = pos })
  4030. in
  4031. let mk_eq cl1 cl2 =
  4032. { eexpr = TBinop(Ast.OpEq, mk_typehandle cl1, mk_typehandle cl2); etype = basic.tbool; epos = pos }
  4033. in
  4034. let rec mk_typehandle_cond thisparams cfparams =
  4035. match thisparams, cfparams with
  4036. | TInst(cl_this,[]) :: [], TInst(cl_cf,[]) :: [] ->
  4037. mk_eq cl_this cl_cf
  4038. | TInst(cl_this,[]) :: hd, TInst(cl_cf,[]) :: hd2 ->
  4039. { eexpr = TBinop(Ast.OpBoolAnd, mk_eq cl_this cl_cf, mk_typehandle_cond hd hd2); etype = basic.tbool; epos = pos }
  4040. | v :: hd, v2 :: hd2 ->
  4041. (match follow v, follow v2 with
  4042. | (TInst(cl1,[]) as v), (TInst(cl2,[]) as v2) ->
  4043. mk_typehandle_cond (v :: hd) (v2 :: hd2)
  4044. | _ ->
  4045. assert false
  4046. )
  4047. | _ -> assert false
  4048. in
  4049. let fn =
  4050. {
  4051. tf_args = [];
  4052. tf_type = t_dynamic;
  4053. tf_expr =
  4054. {
  4055. eexpr = TBlock([
  4056. (* if (typeof(T) == typeof(T2)) return this *)
  4057. {
  4058. eexpr = TIf(
  4059. mk_typehandle_cond (List.map snd cl.cl_params) params,
  4060. mk_return this,
  4061. None);
  4062. etype = basic.tvoid;
  4063. epos = pos;
  4064. };
  4065. (* var new_me = /*special create empty with tparams construct*/ *)
  4066. {
  4067. eexpr = TVar(new_me_var, Some(gen.gtools.rf_create_empty cl params pos));
  4068. etype = gen.gcon.basic.tvoid;
  4069. epos = pos
  4070. };
  4071. (* var fields = Reflect.fields(this); *)
  4072. {
  4073. eexpr = TVar(fields_var, Some(gen.gtools.r_fields true this));
  4074. etype = gen.gcon.basic.tvoid;
  4075. epos = pos
  4076. };
  4077. (* var i = 0; *)
  4078. {
  4079. eexpr = TVar(i_var, Some(mk_int gen 0 pos));
  4080. etype = gen.gcon.basic.tvoid;
  4081. epos = pos
  4082. };
  4083. {
  4084. eexpr = TWhile( (* while (i < fields.length) *)
  4085. {
  4086. eexpr = TBinop(Ast.OpLt,
  4087. local_i,
  4088. mk_field_access gen local_fields "length" pos);
  4089. etype = gen.gcon.basic.tbool;
  4090. epos = pos
  4091. },
  4092. {
  4093. eexpr = TBlock [
  4094. (* var field = fields[i++]; *)
  4095. {
  4096. eexpr = TVar(field_var, Some { eexpr = TArray (local_fields, incr_i); etype = gen.gcon.basic.tstring; epos = pos });
  4097. etype = gen.gcon.basic.tvoid;
  4098. epos = pos
  4099. };
  4100. (
  4101. (* default: Reflect.setField(new_me, field, Reflect.field(this, field)) *)
  4102. let edef = gen.gtools.r_set_field gen.gcon.basic.tvoid local_new_me local_field (gen.gtools.r_field false gen.gcon.basic.tvoid this local_field) in
  4103. if fields <> [] then
  4104. (* switch(field) { ... } *)
  4105. {
  4106. eexpr = TSwitch(local_field, fields_to_cases fields, Some(edef));
  4107. etype = gen.gcon.basic.tvoid;
  4108. epos = pos;
  4109. }
  4110. else
  4111. edef;
  4112. )
  4113. ];
  4114. etype = gen.gcon.basic.tvoid;
  4115. epos = pos
  4116. },
  4117. Ast.NormalWhile
  4118. );
  4119. etype = gen.gcon.basic.tvoid;
  4120. epos = pos;
  4121. };
  4122. (* return new_me *)
  4123. mk_return local_new_me
  4124. ]);
  4125. etype = t_dynamic;
  4126. epos = pos;
  4127. };
  4128. }
  4129. in
  4130. cfield.cf_expr <- Some( { eexpr = TFunction(fn); etype = cfield.cf_type; epos = pos } );
  4131. cfield
  4132. let create_static_cast_cf gen iface cf =
  4133. let p = iface.cl_pos in
  4134. let basic = gen.gcon.basic in
  4135. let cparams = List.map (fun (s,t) -> ("To_" ^ s, TInst (map_param (get_cl_t t), []))) cf.cf_params in
  4136. let me_type = TInst(iface,[]) in
  4137. let cfield = mk_class_field "__hx_cast" (TFun(["me",false,me_type], t_dynamic)) false iface.cl_pos (Method MethNormal) (cparams) in
  4138. let params = List.map snd cparams in
  4139. let me = alloc_var "me" me_type in
  4140. let field = { eexpr = TField(mk_local me p, FInstance(iface, List.map snd iface.cl_params, cf)); etype = apply_params cf.cf_params params cf.cf_type; epos = p } in
  4141. let call =
  4142. {
  4143. eexpr = TCall(field, []);
  4144. etype = t_dynamic;
  4145. epos = p;
  4146. } in
  4147. let call = gen.gparam_func_call call field params [] in
  4148. (* since object.someCall<ExplicitParameterDefinition>() isn't allowed on Haxe, we need to directly apply the params and delay this call *)
  4149. let delay () =
  4150. cfield.cf_expr <-
  4151. Some {
  4152. eexpr = TFunction(
  4153. {
  4154. tf_args = [me,None];
  4155. tf_type = t_dynamic;
  4156. tf_expr =
  4157. {
  4158. eexpr = TReturn( Some
  4159. {
  4160. eexpr = TIf(
  4161. { eexpr = TBinop(Ast.OpNotEq, mk_local me p, null me.v_type p); etype = basic.tbool; epos = p },
  4162. call,
  4163. Some( null me.v_type p )
  4164. );
  4165. etype = t_dynamic;
  4166. epos = p;
  4167. });
  4168. etype = basic.tvoid;
  4169. epos = p;
  4170. }
  4171. });
  4172. etype = cfield.cf_type;
  4173. epos = p;
  4174. }
  4175. in
  4176. cfield, delay
  4177. let get_cast_name cl = String.concat "_" ((fst cl.cl_path) @ [snd cl.cl_path; cast_field_name]) (* explicitly define it *)
  4178. let default_implementation gen ifaces base_generic =
  4179. let add_iface cl =
  4180. gen.gadd_to_module (TClassDecl cl) (max_dep);
  4181. in
  4182. let implement_stub_cast cthis iface tl =
  4183. let name = get_cast_name iface in
  4184. if not (PMap.mem name cthis.cl_fields) then begin
  4185. let cparams = List.map (fun (s,t) -> ("To_" ^ s, TInst(map_param (get_cl_t t), []))) iface.cl_params in
  4186. let field = mk_class_field name (TFun([],t_dynamic)) false iface.cl_pos (Method MethNormal) cparams in
  4187. let this = { eexpr = TConst TThis; etype = TInst(cthis, List.map snd cthis.cl_params); epos = cthis.cl_pos } in
  4188. field.cf_expr <- Some {
  4189. etype = TFun([],t_dynamic);
  4190. epos = this.epos;
  4191. eexpr = TFunction {
  4192. tf_type = t_dynamic;
  4193. tf_args = [];
  4194. tf_expr = mk_block { this with
  4195. eexpr = TReturn (Some this)
  4196. }
  4197. }
  4198. };
  4199. cthis.cl_ordered_fields <- field :: cthis.cl_ordered_fields;
  4200. cthis.cl_fields <- PMap.add name field cthis.cl_fields
  4201. end
  4202. in
  4203. let rec run md =
  4204. match md with
  4205. | TClassDecl ({ cl_params = [] } as cl) ->
  4206. (* see if we're implementing any generic interface *)
  4207. let rec check (iface,tl) =
  4208. if tl <> [] && set_hxgeneric gen (TClassDecl iface) then
  4209. (* implement cast stub *)
  4210. implement_stub_cast cl iface tl;
  4211. List.iter (fun (s,stl) -> check (s, List.map (apply_params iface.cl_params tl) stl)) iface.cl_implements;
  4212. in
  4213. List.iter (check) cl.cl_implements;
  4214. md
  4215. | TClassDecl ({ cl_params = hd :: tl } as cl) when set_hxgeneric gen md ->
  4216. let iface = mk_class cl.cl_module cl.cl_path cl.cl_pos in
  4217. iface.cl_array_access <- Option.map (apply_params (cl.cl_params) (List.map (fun _ -> t_dynamic) cl.cl_params)) cl.cl_array_access;
  4218. iface.cl_extern <- cl.cl_extern;
  4219. iface.cl_module <- cl.cl_module;
  4220. iface.cl_meta <-
  4221. (Meta.HxGen, [], cl.cl_pos)
  4222. ::
  4223. (Meta.Custom "generic_iface", [(EConst(Int(string_of_int(List.length cl.cl_params))), cl.cl_pos)], cl.cl_pos)
  4224. ::
  4225. iface.cl_meta;
  4226. Hashtbl.add ifaces cl.cl_path iface;
  4227. iface.cl_implements <- (base_generic, []) :: iface.cl_implements;
  4228. iface.cl_interface <- true;
  4229. cl.cl_implements <- (iface, []) :: cl.cl_implements;
  4230. let name = get_cast_name cl in
  4231. let cast_cf = create_cast_cfield gen cl name in
  4232. if not cl.cl_interface then create_stub_casts gen cl cast_cf;
  4233. let rec loop c = match c.cl_super with
  4234. | None -> ()
  4235. | Some(sup,_) -> try
  4236. let siface = Hashtbl.find ifaces sup.cl_path in
  4237. iface.cl_implements <- (siface,[]) :: iface.cl_implements;
  4238. ()
  4239. with | Not_found -> loop sup
  4240. in
  4241. loop cl;
  4242. (if not cl.cl_interface then cl.cl_ordered_fields <- cast_cf :: cl.cl_ordered_fields);
  4243. let iface_cf = mk_class_field name cast_cf.cf_type false cast_cf.cf_pos (Method MethNormal) cast_cf.cf_params in
  4244. let cast_static_cf, delay = create_static_cast_cf gen iface iface_cf in
  4245. cl.cl_ordered_statics <- cast_static_cf :: cl.cl_ordered_statics;
  4246. cl.cl_statics <- PMap.add cast_static_cf.cf_name cast_static_cf cl.cl_statics;
  4247. gen.gafter_filters_ended <- delay :: gen.gafter_filters_ended; (* do not let filters alter this expression content *)
  4248. iface_cf.cf_type <- cast_cf.cf_type;
  4249. iface.cl_fields <- PMap.add name iface_cf iface.cl_fields;
  4250. let fields = List.filter (fun cf -> match cf.cf_kind with
  4251. | Var _ | Method MethDynamic -> false
  4252. | _ ->
  4253. let is_override = List.memq cf cl.cl_overrides in
  4254. let cf_type = if is_override && not (Meta.has Meta.Overload cf.cf_meta) then
  4255. match field_access gen (TInst(cl, List.map snd cl.cl_params)) cf.cf_name with
  4256. | FClassField(_,_,_,_,_,actual_t,_) -> actual_t
  4257. | _ -> assert false
  4258. else
  4259. cf.cf_type
  4260. in
  4261. not (has_type_params cf_type)) cl.cl_ordered_fields
  4262. in
  4263. let fields = List.map (fun f -> mk_class_field f.cf_name f.cf_type f.cf_public f.cf_pos f.cf_kind f.cf_params) fields in
  4264. let fields = iface_cf :: fields in
  4265. iface.cl_ordered_fields <- fields;
  4266. List.iter (fun f -> iface.cl_fields <- PMap.add f.cf_name f iface.cl_fields) fields;
  4267. add_iface iface;
  4268. md
  4269. | TTypeDecl _ | TAbstractDecl _ -> md
  4270. | TEnumDecl _ ->
  4271. ignore (set_hxgeneric gen md);
  4272. md
  4273. | _ -> ignore (set_hxgeneric gen md); md
  4274. in
  4275. run
  4276. let configure gen mapping_func =
  4277. let map e = Some(mapping_func e) in
  4278. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  4279. end;;
  4280. (* create a common interface without type parameters and only a __Cast<> function *)
  4281. let default_implementation gen (dyn_tparam_cast:texpr->t->texpr) ifaces =
  4282. let change_expr e cl iface params =
  4283. let field = mk_static_field_access_infer cl "__hx_cast" e.epos params in
  4284. let elist = [mk_cast (TInst(iface,[])) e] in
  4285. let call = { eexpr = TCall(field, elist); etype = t_dynamic; epos = e.epos } in
  4286. gen.gparam_func_call call field params elist
  4287. in
  4288. let rec run e =
  4289. match e.eexpr with
  4290. | TCast(cast_expr, _) ->
  4291. (* see if casting to a native generic class *)
  4292. let t = gen.greal_type e.etype in
  4293. let unifies =
  4294. let ctype = gen.greal_type cast_expr.etype in
  4295. match follow ctype with
  4296. | TInst(cl,_) -> (try
  4297. unify ctype t;
  4298. true
  4299. with | Unify_error el ->
  4300. false)
  4301. | _ -> false
  4302. in
  4303. let unifies = unifies && not (PMap.mem "cs_safe_casts" gen.gcon.defines) in
  4304. (match follow t with
  4305. | TInst(cl, p1 :: pl) when is_hxgeneric (TClassDecl cl) && not unifies && not (Meta.has Meta.Enum cl.cl_meta) ->
  4306. let iface = Hashtbl.find ifaces cl.cl_path in
  4307. mk_cast e.etype (change_expr (Type.map_expr run cast_expr) cl iface (p1 :: pl))
  4308. | _ -> Type.map_expr run e
  4309. )
  4310. | _ -> Type.map_expr run e
  4311. in
  4312. run
  4313. let configure gen traverse =
  4314. gen.ghas_tparam_cast_handler <- true;
  4315. let map e = Some(traverse e) in
  4316. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  4317. let default_config gen (dyn_tparam_cast:texpr->t->texpr) ifaces base_generic =
  4318. configure gen (default_implementation gen dyn_tparam_cast ifaces);
  4319. RealTypeParamsModf.configure gen (RealTypeParamsModf.default_implementation gen ifaces base_generic)
  4320. end;;
  4321. (* ******************************************* *)
  4322. (* Rename Type Parameters *)
  4323. (* ******************************************* *)
  4324. (*
  4325. This module should run after everything is already applied,
  4326. it will look for possible type parameter name clashing and change the classes names to a
  4327. dependencies:
  4328. should run after everything is already applied. There's no configure on this module, only 'run'.
  4329. *)
  4330. module RenameTypeParameters =
  4331. struct
  4332. let name = "rename_type_parameters"
  4333. let run gen =
  4334. let i = ref 0 in
  4335. let found_types = ref PMap.empty in
  4336. let check_type name on_changed =
  4337. let rec loop name =
  4338. incr i;
  4339. let changed_name = (name ^ (string_of_int !i)) in
  4340. if PMap.mem changed_name !found_types then loop name else changed_name
  4341. in
  4342. if PMap.mem name !found_types then begin
  4343. let new_name = loop name in
  4344. found_types := PMap.add new_name true !found_types;
  4345. on_changed new_name
  4346. end else found_types := PMap.add name true !found_types
  4347. in
  4348. let get_cls t =
  4349. match follow t with
  4350. | TInst(cl,_) -> cl
  4351. | _ -> assert false
  4352. in
  4353. let iter_types (nt,t) =
  4354. let cls = get_cls t in
  4355. let orig = cls.cl_path in
  4356. check_type (snd orig) (fun name -> cls.cl_path <- (fst orig, name))
  4357. in
  4358. let save_params save params =
  4359. List.fold_left (fun save (_,t) ->
  4360. let cls = get_cls t in
  4361. (cls.cl_path,t) :: save) save params
  4362. in
  4363. List.iter (function
  4364. | TClassDecl cl ->
  4365. i := 0;
  4366. let save = [] in
  4367. found_types := PMap.empty;
  4368. let save = save_params save cl.cl_params in
  4369. List.iter iter_types cl.cl_params;
  4370. let cur_found_types = !found_types in
  4371. let save = ref save in
  4372. List.iter (fun cf ->
  4373. found_types := cur_found_types;
  4374. save := save_params !save cf.cf_params;
  4375. List.iter iter_types cf.cf_params
  4376. ) (cl.cl_ordered_fields @ cl.cl_ordered_statics);
  4377. if !save <> [] then begin
  4378. let save = !save in
  4379. let res = cl.cl_restore in
  4380. cl.cl_restore <- (fun () ->
  4381. res();
  4382. List.iter (fun (path,t) ->
  4383. let cls = get_cls t in
  4384. cls.cl_path <- path) save
  4385. );
  4386. end
  4387. | TEnumDecl ( ({ e_params = hd :: tl }) ) ->
  4388. i := 0;
  4389. found_types := PMap.empty;
  4390. List.iter iter_types (hd :: tl)
  4391. | TAbstractDecl { a_params = hd :: tl } ->
  4392. i := 0;
  4393. found_types := PMap.empty;
  4394. List.iter iter_types (hd :: tl)
  4395. | _ -> ()
  4396. ) gen.gtypes_list
  4397. end;;
  4398. let configure gen (param_func_call:texpr->texpr->tparams->texpr list->texpr) =
  4399. (*let map e = Some(mapping_func e) in
  4400. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map*)
  4401. gen.gparam_func_call <- param_func_call
  4402. end;;
  4403. (**************************************************************************************************************************)
  4404. (* SYNTAX FILTERS *)
  4405. (**************************************************************************************************************************)
  4406. (* ******************************************* *)
  4407. (* Expression Unwrap *)
  4408. (* ******************************************* *)
  4409. (*
  4410. This is the most important module for source-code based targets. It will follow a convention of what's an expression and what's a statement,
  4411. and will unwrap statements where expressions are expected, and vice-versa.
  4412. It should be one of the first syntax filters to be applied. As a consequence, it's applied after all filters that add code to the AST, and by being
  4413. the first of the syntax filters, it will also have the AST retain most of the meaning of normal Haxe code. So it's easier to detect cases which are
  4414. side-effects free, for example
  4415. Any target can make use of this, but there is one requirement: The target must accept null to be set to any kind of variable. For example,
  4416. var i:Int = null; must be accepted. The best way to deal with this is to (like it's done in C#) make null equal to "default(Type)"
  4417. dependencies:
  4418. While it's best for Expression Unwrap to delay its execution as much as possible, since theoretically any
  4419. filter can return an expression that needs to be unwrapped, it is also desirable for ExpresionUnwrap to have
  4420. the AST as close as possible as Haxe's, so it can make some correct predictions (for example, so it can
  4421. more accurately know what can be side-effects-free and what can't).
  4422. This way, it will run slightly after the Normal priority, so if you don't say that a syntax filter must run
  4423. before Expression Unwrap, it will run after it.
  4424. TODO : While statement must become do / while, with the actual block inside an if for the condition, and else for 'break'
  4425. *)
  4426. module ExpressionUnwrap =
  4427. struct
  4428. let name = "expression_unwrap"
  4429. (* priority: first syntax filter *)
  4430. let priority = -10.0
  4431. (*
  4432. We always need to rely on Blocks to be able to unwrap expressions correctly.
  4433. So the the standard traverse will always be based on blocks.
  4434. Normal block statements, like for(), while(), if(), ... will be mk_block'ed so there is always a block inside of them.
  4435. At the block level, we'll define an "add_statement" function, which will allow the current expression to
  4436. add statements to the block. This statement may or may not contain statements as expressions, so the texpr will be evaluated recursively before being added.
  4437. - traverse will always evaluate TBlocks
  4438. - for each texpr in a TBlock list,
  4439. check shallow type
  4440. if type is Statement or Both when it has problematic expression (var problematic_expr = count_problematic_expressions),
  4441. if we can eagerly call unwrap_statement on the whole expression (try_call_unwrap_statement), use the return expression
  4442. else
  4443. check expr_type of each underlying type (with expr_stat_map)
  4444. if it has ExprWithStatement or Statement,
  4445. call problematic_expression_unwrap in it
  4446. problematic_expr--
  4447. else if problematic_expr == 0, just add the unchanged expression
  4448. else if NoSideEffects and doesn't have short-circuit, just add the unchanged expression
  4449. else call problematic_expression_unwrap in it
  4450. if type is Expression, check if there are statements or Both inside.
  4451. if there are, problematic_expression_unwrap in it
  4452. aftewards, use on_expr_as_statement to get it
  4453. helpers:
  4454. try_call_unwrap_statement: (returns texpr option)
  4455. if underlying statement is TBinop(OpAssign/OpAssignOp), or TVar, with the right side being a Statement or a short circuit op, we can call apply_assign.
  4456. apply_assign:
  4457. if is TVar, first declare the tvar with default expression = null;
  4458. will receive the left and right side of the assignment; right-side must be Statement
  4459. see if right side is a short-circuit operation, call short_circuit_op_unwrap
  4460. else see eexpr of the right side
  4461. if it's void, just add the statement with add_statement, and set the right side as null;
  4462. if not, it will have a block inside. set the left side = to the last expression on each block inside. add_statement for it.
  4463. short_circuit_op_unwrap: x() && (1 + {var x = 0; x + 1;} == 2) && z()
  4464. -> var x = x();
  4465. var y = false;
  4466. var z = false;
  4467. if (x) //for &&, neg for ||
  4468. {
  4469. var temp = null;
  4470. {
  4471. var x = 0;
  4472. temp = x + 1;
  4473. }
  4474. y = (1 + temp) == 2;
  4475. if (y)
  4476. {
  4477. z = z();
  4478. }
  4479. }
  4480. expects to receive a texpr with TBinop(OpBoolAnd/OpBoolOr)
  4481. will traverse the AST while there is a TBinop(OpBoolAnd/OpBoolOr) as a right-side expr, and declare new temp vars in the for each found.
  4482. will collect the return value, a mapped expr with all exprs as TLocal of the temp vars created
  4483. problematic_expression_unwrap:
  4484. check expr_kind:
  4485. if it is NoSideEffects and not short-circuit, leave it there
  4486. if it is ExprWithStatement and not short-circuit, call Type.map_expr problematic_expression_unwrap
  4487. if it is Statement or Expression or short-circuit expr, call add_assign for this expression
  4488. add_assign:
  4489. see if the type is void. If it is, just add_statement the expression argument, and return a null value
  4490. else create a new variable, set TVar with Some() with the expression argument, add TVar with add_statement, and return the TLocal of this expression.
  4491. map_problematic_expr:
  4492. call expr_stat_map on statement with problematic_expression_unwrap
  4493. types:
  4494. type shallow_expr_type = | Statement | Expression | Both (* shallow expression classification. Both means that they can be either Statements as Expressions *)
  4495. type expr_kind = | NormalExpr | ExprNoSideEffects (* -> short-circuit is considered side-effects *) | ExprWithStatement | Statement
  4496. evaluates an expression (as in not a statement) type. If it is ExprWithStatement or Statement, it means it contains errors
  4497. functions:
  4498. shallow_expr_type (expr:texpr) : shallow_expr_type
  4499. expr_kind (expr:texpr) : expr_kind
  4500. deeply evaluates an expression type
  4501. expr_stat_map (fn:texpr->texpr) (expr:texpr) : texpr
  4502. it will traverse the AST looking for places where an expression is expected, and map the value according to fn
  4503. aggregate_expr_type (is_side_effects_free:bool) (children:expr_type list) : expr_type
  4504. helper function to deal with expr_type aggregation (e.g. an Expression + a Statement as a children, is a ExprWithStatement)
  4505. check_statement_in_expression (expr:texpr) : texpr option :
  4506. will check
  4507. *)
  4508. type shallow_expr_type = | Statement | Expression of texpr | Both of texpr (* shallow expression classification. Both means that they can be either Statements as Expressions *)
  4509. type expr_kind = | KNormalExpr | KNoSideEffects (* -> short-circuit is considered side-effects *) | KExprWithStatement | KStatement
  4510. let rec no_paren e =
  4511. match e.eexpr with
  4512. | TParenthesis e -> no_paren e
  4513. | _ -> e
  4514. (* must be called in a statement. Will execute fn whenever an expression (not statement) is expected *)
  4515. let rec expr_stat_map fn (expr:texpr) =
  4516. match (no_paren expr).eexpr with
  4517. | TBinop ( (Ast.OpAssign as op), left_e, right_e )
  4518. | TBinop ( (Ast.OpAssignOp _ as op), left_e, right_e ) ->
  4519. { expr with eexpr = TBinop(op, fn left_e, fn right_e) }
  4520. | TParenthesis _ -> assert false
  4521. | TCall(left_e, params) ->
  4522. { expr with eexpr = TCall(fn left_e, List.map fn params) }
  4523. | TNew(cl, tparams, params) ->
  4524. { expr with eexpr = TNew(cl, tparams, List.map fn params) }
  4525. | TVar(v,eopt) ->
  4526. { expr with eexpr = TVar(v, Option.map fn eopt) }
  4527. | TFor (v,cond,block) ->
  4528. { expr with eexpr = TFor(v, fn cond, block) }
  4529. | TIf(cond,eif,eelse) ->
  4530. { expr with eexpr = TIf(fn cond, eif, eelse) }
  4531. | TWhile(cond, block, flag) ->
  4532. { expr with eexpr = TWhile(fn cond, block, flag) }
  4533. | TSwitch(cond, el_block_l, default) ->
  4534. { expr with eexpr = TSwitch( fn cond, List.map (fun (el,block) -> (List.map fn el, block)) el_block_l, default ) }
  4535. (* | TMatch(cond, enum, cases, default) ->
  4536. { expr with eexpr = TMatch(fn cond, enum, cases, default) } *)
  4537. | TReturn(eopt) ->
  4538. { expr with eexpr = TReturn(Option.map fn eopt) }
  4539. | TThrow (texpr) ->
  4540. { expr with eexpr = TThrow(fn texpr) }
  4541. | TBreak
  4542. | TContinue
  4543. | TTry _
  4544. | TUnop (Ast.Increment, _, _)
  4545. | TUnop (Ast.Decrement, _, _) (* unop is a special case because the haxe compiler won't let us generate complex expressions with Increment/Decrement *)
  4546. | TBlock _ -> expr (* there is no expected expression here. Only statements *)
  4547. | TMeta(m,e) ->
  4548. { expr with eexpr = TMeta(m,expr_stat_map fn e) }
  4549. | _ -> assert false (* we only expect valid statements here. other expressions aren't valid statements *)
  4550. let is_expr = function | Expression _ -> true | _ -> false
  4551. let aggregate_expr_type map_fn side_effects_free children =
  4552. let rec loop acc children =
  4553. match children with
  4554. | [] -> acc
  4555. | hd :: children ->
  4556. match acc, map_fn hd with
  4557. | _, KExprWithStatement
  4558. | _, KStatement
  4559. | KExprWithStatement, _
  4560. | KStatement, _ -> KExprWithStatement
  4561. | KNormalExpr, KNoSideEffects
  4562. | KNoSideEffects, KNormalExpr
  4563. | KNormalExpr, KNormalExpr -> loop KNormalExpr children
  4564. | KNoSideEffects, KNoSideEffects -> loop KNoSideEffects children
  4565. in
  4566. loop (if side_effects_free then KNoSideEffects else KNormalExpr) children
  4567. (* statements: *)
  4568. (* Error CS0201: Only assignment, call, increment, *)
  4569. (* decrement, and new object expressions can be used as a *)
  4570. (* statement (CS0201). *)
  4571. let rec shallow_expr_type expr : shallow_expr_type =
  4572. match expr.eexpr with
  4573. | TCall _ when not (is_void expr.etype) -> Both expr
  4574. | TNew _
  4575. | TUnop (Ast.Increment, _, _)
  4576. | TUnop (Ast.Decrement, _, _)
  4577. | TBinop (Ast.OpAssign, _, _)
  4578. | TBinop (Ast.OpAssignOp _, _, _) -> Both expr
  4579. | TIf (cond, eif, Some(eelse)) -> (match aggregate_expr_type expr_kind true [cond;eif;eelse] with
  4580. | KExprWithStatement -> Statement
  4581. | _ -> Both expr)
  4582. | TConst _
  4583. | TLocal _
  4584. | TArray _
  4585. | TBinop _
  4586. | TField _
  4587. | TEnumParameter _
  4588. | TTypeExpr _
  4589. | TObjectDecl _
  4590. | TArrayDecl _
  4591. | TFunction _
  4592. | TCast _
  4593. | TUnop _ -> Expression (expr)
  4594. | TParenthesis p | TMeta(_,p) -> shallow_expr_type p
  4595. | TBlock ([e]) -> shallow_expr_type e
  4596. | TCall _
  4597. | TVar _
  4598. | TBlock _
  4599. | TFor _
  4600. | TWhile _
  4601. | TSwitch _
  4602. | TTry _
  4603. | TReturn _
  4604. | TBreak
  4605. | TContinue
  4606. | TIf _
  4607. | TThrow _ -> Statement
  4608. and expr_kind expr =
  4609. match shallow_expr_type expr with
  4610. | Statement -> KStatement
  4611. | Both expr | Expression expr ->
  4612. let aggregate = aggregate_expr_type expr_kind in
  4613. match expr.eexpr with
  4614. | TConst _
  4615. | TLocal _
  4616. | TFunction _
  4617. | TTypeExpr _ ->
  4618. KNoSideEffects
  4619. | TCall (ecall, params) ->
  4620. aggregate false (ecall :: params)
  4621. | TNew (_,_,params) ->
  4622. aggregate false params
  4623. | TUnop (Increment,_,e)
  4624. | TUnop (Decrement,_,e) ->
  4625. aggregate false [e]
  4626. | TUnop (_,_,e) ->
  4627. aggregate true [e]
  4628. | TBinop (Ast.OpBoolAnd, e1, e2)
  4629. | TBinop (Ast.OpBoolOr, e1, e2) -> (* TODO: should OpBool never be side-effects free? *)
  4630. aggregate true [e1;e2]
  4631. | TBinop (Ast.OpAssign, e1, e2)
  4632. | TBinop (Ast.OpAssignOp _, e1, e2) ->
  4633. aggregate false [e1;e2]
  4634. | TBinop (_, e1, e2) ->
  4635. aggregate true [e1;e2]
  4636. | TIf (cond, eif, Some(eelse)) -> (match aggregate true [cond;eif;eelse] with
  4637. | KExprWithStatement -> KStatement
  4638. | k -> k)
  4639. | TArray (e1,e2) ->
  4640. aggregate true [e1;e2]
  4641. | TParenthesis e
  4642. | TMeta(_,e)
  4643. | TField (e,_) ->
  4644. aggregate true [e]
  4645. | TArrayDecl (el) ->
  4646. aggregate true el
  4647. | TObjectDecl (sel) ->
  4648. aggregate true (List.map snd sel)
  4649. | TCast (e,_) ->
  4650. aggregate true [e]
  4651. | _ -> trace (debug_expr expr); assert false (* should have been read as Statement by shallow_expr_type *)
  4652. let is_side_effects_free e =
  4653. match expr_kind e with | KNoSideEffects -> true | _ -> false
  4654. let get_kinds (statement:texpr) =
  4655. let kinds = ref [] in
  4656. ignore (expr_stat_map (fun e ->
  4657. kinds := (expr_kind e) :: !kinds;
  4658. e
  4659. ) statement);
  4660. List.rev !kinds
  4661. let has_problematic_expressions (kinds:expr_kind list) =
  4662. let rec loop kinds =
  4663. match kinds with
  4664. | [] -> false
  4665. | KStatement :: _
  4666. | KExprWithStatement :: _ -> true
  4667. | _ :: tl -> loop tl
  4668. in
  4669. loop kinds
  4670. let count_problematic_expressions (statement:texpr) =
  4671. let count = ref 0 in
  4672. ignore (expr_stat_map (fun e ->
  4673. (match expr_kind e with
  4674. | KStatement | KExprWithStatement -> incr count
  4675. | _ -> ()
  4676. );
  4677. e
  4678. ) statement);
  4679. !count
  4680. let apply_assign_block assign_fun elist =
  4681. let rec assign acc elist =
  4682. match elist with
  4683. | [] -> acc
  4684. | last :: [] ->
  4685. (assign_fun last) :: acc
  4686. | hd :: tl ->
  4687. assign (hd :: acc) tl
  4688. in
  4689. List.rev (assign [] elist)
  4690. let mk_get_block assign_fun e =
  4691. match e.eexpr with
  4692. | TBlock [] -> e
  4693. | TBlock (el) ->
  4694. { e with eexpr = TBlock(apply_assign_block assign_fun el) }
  4695. | _ ->
  4696. { e with eexpr = TBlock([ assign_fun e ]) }
  4697. let add_assign gen add_statement expr =
  4698. match expr.eexpr, follow expr.etype with
  4699. | _, TAbstract ({ a_path = ([],"Void") },[])
  4700. | TThrow _, _ ->
  4701. add_statement expr;
  4702. null expr.etype expr.epos
  4703. | _ ->
  4704. let var = mk_temp gen "stmt" expr.etype in
  4705. let tvars = { expr with eexpr = TVar(var,Some(expr)) } in
  4706. let local = { expr with eexpr = TLocal(var) } in
  4707. add_statement tvars;
  4708. local
  4709. (* requirement: right must be a statement *)
  4710. let rec apply_assign assign_fun right =
  4711. match right.eexpr with
  4712. | TBlock el ->
  4713. { right with eexpr = TBlock(apply_assign_block assign_fun el) }
  4714. | TSwitch (cond, elblock_l, default) ->
  4715. { right with eexpr = TSwitch(cond, List.map (fun (el,block) -> (el, mk_get_block assign_fun block)) elblock_l, Option.map (mk_get_block assign_fun) default) }
  4716. (* | TMatch (cond, ep, il_vlo_e_l, default) ->
  4717. { right with eexpr = TMatch(cond, ep, List.map (fun (il,vlo,e) -> (il,vlo,mk_get_block assign_fun e)) il_vlo_e_l, Option.map (mk_get_block assign_fun) default) } *)
  4718. | TTry (block, catches) ->
  4719. { right with eexpr = TTry(mk_get_block assign_fun block, List.map (fun (v,block) -> (v,mk_get_block assign_fun block) ) catches) }
  4720. | TIf (cond,eif,eelse) ->
  4721. { right with eexpr = TIf(cond, mk_get_block assign_fun eif, Option.map (mk_get_block assign_fun) eelse) }
  4722. | TThrow _
  4723. | TWhile _
  4724. | TFor _
  4725. | TReturn _
  4726. | TBreak
  4727. | TContinue -> right
  4728. | TParenthesis p | TMeta(_,p) ->
  4729. apply_assign assign_fun p
  4730. | TVar _ ->
  4731. right
  4732. | _ ->
  4733. match follow right.etype with
  4734. | TAbstract ({ a_path = ([], "Void") },[]) ->
  4735. right
  4736. | _ -> trace (debug_expr right); assert false (* a statement is required *)
  4737. let short_circuit_op_unwrap gen add_statement expr :texpr =
  4738. let do_not expr =
  4739. { expr with eexpr = TUnop(Ast.Not, Ast.Prefix, expr) }
  4740. in
  4741. (* loop will always return its own TBlock, and the mapped expression *)
  4742. let rec loop acc expr =
  4743. match expr.eexpr with
  4744. | TBinop ( (Ast.OpBoolAnd as op), left, right) ->
  4745. let var = mk_temp gen "boolv" right.etype in
  4746. let tvars = { right with eexpr = TVar(var, Some( { right with eexpr = TConst(TBool false); etype = gen.gcon.basic.tbool } )); etype = gen.gcon.basic.tvoid } in
  4747. let local = { right with eexpr = TLocal(var) } in
  4748. let mapped_left, ret_acc = loop ( (local, { right with eexpr = TBinop(Ast.OpAssign, local, right) } ) :: acc) left in
  4749. add_statement tvars;
  4750. ({ expr with eexpr = TBinop(op, mapped_left, local) }, ret_acc)
  4751. (* we only accept OpBoolOr when it's the first to be evaluated *)
  4752. | TBinop ( (Ast.OpBoolOr as op), left, right) when acc = [] ->
  4753. let left = match left.eexpr with
  4754. | TLocal _ | TConst _ -> left
  4755. | _ -> add_assign gen add_statement left
  4756. in
  4757. let var = mk_temp gen "boolv" right.etype in
  4758. let tvars = { right with eexpr = TVar(var, Some( { right with eexpr = TConst(TBool false); etype = gen.gcon.basic.tbool } )); etype = gen.gcon.basic.tvoid } in
  4759. let local = { right with eexpr = TLocal(var) } in
  4760. add_statement tvars;
  4761. ({ expr with eexpr = TBinop(op, left, local) }, [ do_not left, { right with eexpr = TBinop(Ast.OpAssign, local, right) } ])
  4762. | _ when acc = [] -> assert false
  4763. | _ ->
  4764. let var = mk_temp gen "boolv" expr.etype in
  4765. let tvars = { expr with eexpr = TVar(var, Some( { expr with etype = gen.gcon.basic.tbool } )); etype = gen.gcon.basic.tvoid } in
  4766. let local = { expr with eexpr = TLocal(var) } in
  4767. let last_local = ref local in
  4768. let acc = List.map (fun (local, assign) ->
  4769. let l = !last_local in
  4770. last_local := local;
  4771. (l, assign)
  4772. ) acc in
  4773. add_statement tvars;
  4774. (local, acc)
  4775. in
  4776. let mapped_expr, local_assign_list = loop [] expr in
  4777. let rec loop local_assign_list : texpr =
  4778. match local_assign_list with
  4779. | [local, assign] ->
  4780. { eexpr = TIf(local, assign, None); etype = gen.gcon.basic.tvoid; epos = assign.epos }
  4781. | (local, assign) :: tl ->
  4782. { eexpr = TIf(local,
  4783. {
  4784. eexpr = TBlock ( assign :: [loop tl] );
  4785. etype = gen.gcon.basic.tvoid;
  4786. epos = assign.epos;
  4787. },
  4788. None); etype = gen.gcon.basic.tvoid; epos = assign.epos }
  4789. | [] -> assert false
  4790. in
  4791. add_statement (loop local_assign_list);
  4792. mapped_expr
  4793. (* there are two short_circuit fuctions as I'm still testing the best way to do it *)
  4794. (*let short_circuit_op_unwrap gen add_statement expr :texpr =
  4795. let block = ref [] in
  4796. let rec short_circuit_op_unwrap is_first last_block expr =
  4797. match expr.eexpr with
  4798. | TBinop ( (Ast.OpBoolAnd as op), left, right)
  4799. | TBinop ( (Ast.OpBoolOr as op), left, right) ->
  4800. let var = mk_temp gen "boolv" left.etype in
  4801. let tvars = { left with eexpr = TVar([var, if is_first then Some(left) else Some( { left with eexpr = TConst(TBool false) } )]); etype = gen.gcon.basic.tvoid } in
  4802. let local = { left with eexpr = TLocal(var) } in
  4803. if not is_first then begin
  4804. last_block := !last_block @ [ { left with eexpr = TBinop(Ast.OpAssign, local, left) } ]
  4805. end;
  4806. add_statement tvars;
  4807. let local_op = match op with | Ast.OpBoolAnd -> local | Ast.OpBoolOr -> { local with eexpr = TUnop(Ast.Not, Ast.Prefix, local) } | _ -> assert false in
  4808. let new_block = ref [] in
  4809. let new_right = short_circuit_op_unwrap false new_block right in
  4810. last_block := !last_block @ [ { expr with eexpr = TIf(local_op, { right with eexpr = TBlock(!new_block) }, None) } ];
  4811. { expr with eexpr = TBinop(op, local, new_right) }
  4812. | _ when is_first -> assert false
  4813. | _ ->
  4814. let var = mk_temp gen "boolv" expr.etype in
  4815. let tvars = { expr with eexpr = TVar([var, Some ( { expr with eexpr = TConst(TBool false) } ) ]); etype = gen.gcon.basic.tvoid } in
  4816. let local = { expr with eexpr = TLocal(var) } in
  4817. last_block := !last_block @ [ { expr with eexpr = TBinop(Ast.OpAssign, local, expr) } ];
  4818. add_statement tvars;
  4819. local
  4820. in
  4821. let mapped_expr = short_circuit_op_unwrap true block expr in
  4822. add_statement { eexpr = TBlock(!block); etype = gen.gcon.basic.tvoid; epos = expr.epos };
  4823. mapped_expr*)
  4824. let twhile_with_condition_statement gen add_statement twhile cond e1 flag =
  4825. (* when a TWhile is found with a problematic condition *)
  4826. let basic = gen.gcon.basic in
  4827. let block = if flag = Ast.NormalWhile then
  4828. { e1 with eexpr = TIf(cond, e1, Some({ e1 with eexpr = TBreak; etype = basic.tvoid })) }
  4829. else
  4830. Type.concat e1 { e1 with
  4831. eexpr = TIf({
  4832. eexpr = TUnop(Ast.Not, Ast.Prefix, mk_paren cond);
  4833. etype = basic.tbool;
  4834. epos = cond.epos
  4835. }, { e1 with eexpr = TBreak; etype = basic.tvoid }, None);
  4836. etype = basic.tvoid
  4837. }
  4838. in
  4839. add_statement { twhile with
  4840. eexpr = TWhile(
  4841. { eexpr = TConst(TBool true); etype = basic.tbool; epos = cond.epos },
  4842. block,
  4843. Ast.DoWhile
  4844. );
  4845. }
  4846. let try_call_unwrap_statement gen problematic_expression_unwrap (add_statement:texpr->unit) (expr:texpr) : texpr option =
  4847. let check_left left =
  4848. match expr_kind left with
  4849. | KExprWithStatement ->
  4850. problematic_expression_unwrap add_statement left KExprWithStatement
  4851. | KStatement -> assert false (* doesn't make sense a KStatement as a left side expression *)
  4852. | _ -> left
  4853. in
  4854. let handle_assign op left right =
  4855. let left = check_left left in
  4856. Some (apply_assign (fun e -> { e with eexpr = TBinop(op, left, if is_void left.etype then e else gen.ghandle_cast left.etype e.etype e) }) right )
  4857. in
  4858. let handle_return e =
  4859. Some( apply_assign (fun e ->
  4860. match e.eexpr with
  4861. | TThrow _ -> e
  4862. | _ when is_void e.etype ->
  4863. { e with eexpr = TBlock([e; { e with eexpr = TReturn None }]) }
  4864. | _ ->
  4865. { e with eexpr = TReturn( Some e ) }
  4866. ) e )
  4867. in
  4868. let is_problematic_if right =
  4869. match expr_kind right with
  4870. | KStatement | KExprWithStatement -> true
  4871. | _ -> false
  4872. in
  4873. match expr.eexpr with
  4874. | TBinop((Ast.OpAssign as op),left,right)
  4875. | TBinop((Ast.OpAssignOp _ as op),left,right) when shallow_expr_type right = Statement ->
  4876. handle_assign op left right
  4877. | TReturn( Some right ) when shallow_expr_type right = Statement ->
  4878. handle_return right
  4879. | TBinop((Ast.OpAssign as op),left, ({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right) )
  4880. | TBinop((Ast.OpAssign as op),left,({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right))
  4881. | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right) )
  4882. | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right) ) ->
  4883. let right = short_circuit_op_unwrap gen add_statement right in
  4884. Some { expr with eexpr = TBinop(op, check_left left, right) }
  4885. | TVar(v,Some({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right))
  4886. | TVar(v,Some({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right)) ->
  4887. let right = short_circuit_op_unwrap gen add_statement right in
  4888. Some { expr with eexpr = TVar(v, Some(right)) }
  4889. | TVar(v,Some(right)) when shallow_expr_type right = Statement ->
  4890. add_statement ({ expr with eexpr = TVar(v, Some(null right.etype right.epos)) });
  4891. handle_assign Ast.OpAssign { expr with eexpr = TLocal(v); etype = v.v_type } right
  4892. (* TIf handling *)
  4893. | TBinop((Ast.OpAssign as op),left, ({ eexpr = TIf _ } as right))
  4894. | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TIf _ } as right)) when is_problematic_if right ->
  4895. handle_assign op left right
  4896. | TVar(v,Some({ eexpr = TIf _ } as right)) when is_problematic_if right ->
  4897. add_statement ({ expr with eexpr = TVar(v, Some(null right.etype right.epos)) });
  4898. handle_assign Ast.OpAssign { expr with eexpr = TLocal(v); etype = v.v_type } right
  4899. | TWhile(cond, e1, flag) when is_problematic_if cond ->
  4900. twhile_with_condition_statement gen add_statement expr cond e1 flag;
  4901. Some (null expr.etype expr.epos)
  4902. | _ -> None
  4903. let traverse gen (on_expr_as_statement:texpr->texpr option) =
  4904. let add_assign = add_assign gen in
  4905. let problematic_expression_unwrap add_statement expr e_type =
  4906. let rec problematic_expression_unwrap is_first expr e_type =
  4907. match e_type, expr.eexpr with
  4908. | _, TBinop(Ast.OpBoolAnd, _, _)
  4909. | _, TBinop(Ast.OpBoolOr, _, _) -> add_assign add_statement expr (* add_assign so try_call_unwrap_expr *)
  4910. | KNoSideEffects, _ -> expr
  4911. | KStatement, _
  4912. | KNormalExpr, _ -> add_assign add_statement expr
  4913. | KExprWithStatement, TCall _
  4914. | KExprWithStatement, TNew _
  4915. | KExprWithStatement, TBinop (Ast.OpAssign,_,_)
  4916. | KExprWithStatement, TBinop (Ast.OpAssignOp _,_,_)
  4917. | KExprWithStatement, TUnop (Ast.Increment,_,_) (* all of these may have side-effects, so they must also be add_assign'ed . is_first avoids infinite loop *)
  4918. | KExprWithStatement, TUnop (Ast.Decrement,_,_) when not is_first -> add_assign add_statement expr
  4919. (* bugfix: Type.map_expr doesn't guarantee the correct order of execution *)
  4920. | KExprWithStatement, TBinop(op,e1,e2) ->
  4921. let e1 = problematic_expression_unwrap false e1 (expr_kind e1) in
  4922. let e2 = problematic_expression_unwrap false e2 (expr_kind e2) in
  4923. { expr with eexpr = TBinop(op, e1, e2) }
  4924. | KExprWithStatement, TArray(e1,e2) ->
  4925. let e1 = problematic_expression_unwrap false e1 (expr_kind e1) in
  4926. let e2 = problematic_expression_unwrap false e2 (expr_kind e2) in
  4927. { expr with eexpr = TArray(e1, e2) }
  4928. (* bugfix: calls should not be transformed into closure calls *)
  4929. | KExprWithStatement, TCall(( { eexpr = TField (ef_left, f) } as ef ), eargs) ->
  4930. { expr with eexpr = TCall(
  4931. { ef with eexpr = TField(problematic_expression_unwrap false ef_left (expr_kind ef_left), f) },
  4932. List.map (fun e -> problematic_expression_unwrap false e (expr_kind e)) eargs)
  4933. }
  4934. | KExprWithStatement, _ -> Type.map_expr (fun e -> problematic_expression_unwrap false e (expr_kind e)) expr
  4935. in
  4936. problematic_expression_unwrap true expr e_type
  4937. in
  4938. let rec traverse e =
  4939. match e.eexpr with
  4940. | TBlock el ->
  4941. let new_block = ref [] in
  4942. let rec process_statement e =
  4943. let e = no_paren e in
  4944. match e.eexpr, shallow_expr_type e with
  4945. | TCall( { eexpr = TLocal v } as elocal, elist ), _ when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name ->
  4946. new_block := { e with eexpr = TCall( elocal, List.map (fun e ->
  4947. match e.eexpr with
  4948. | TBlock _ -> traverse e
  4949. | _ -> e
  4950. ) elist ) } :: !new_block
  4951. | _, Statement | _, Both _ ->
  4952. let e = match e.eexpr with | TReturn (Some ({ eexpr = TThrow _ } as ethrow)) -> ethrow | _ -> e in
  4953. let kinds = get_kinds e in
  4954. if has_problematic_expressions kinds then begin
  4955. match try_call_unwrap_statement gen problematic_expression_unwrap add_statement e with
  4956. | Some { eexpr = TConst(TNull) } (* no op *)
  4957. | Some { eexpr = TBlock [] } -> ()
  4958. | Some e ->
  4959. if has_problematic_expressions (get_kinds e) then begin
  4960. process_statement e
  4961. end else
  4962. new_block := (traverse e) :: !new_block
  4963. | None ->
  4964. (
  4965. let acc = ref kinds in
  4966. let new_e = expr_stat_map (fun e ->
  4967. match !acc with
  4968. | hd :: tl ->
  4969. acc := tl;
  4970. if has_problematic_expressions (hd :: tl) then begin
  4971. problematic_expression_unwrap add_statement e hd
  4972. end else
  4973. e
  4974. | [] -> assert false
  4975. ) e in
  4976. new_block := (traverse new_e) :: !new_block
  4977. )
  4978. end else begin new_block := (traverse e) :: !new_block end
  4979. | _, Expression e ->
  4980. match on_expr_as_statement e with
  4981. | None -> ()
  4982. | Some e -> process_statement e
  4983. and add_statement expr =
  4984. process_statement expr
  4985. in
  4986. List.iter (process_statement) el;
  4987. let block = List.rev !new_block in
  4988. { e with eexpr = TBlock(block) }
  4989. | TTry (block, catches) ->
  4990. { e with eexpr = TTry(traverse (mk_block block), List.map (fun (v,block) -> (v, traverse (mk_block block))) catches) }
  4991. (* | TMatch (cond,ep,il_vol_e_l,default) ->
  4992. { e with eexpr = TMatch(cond,ep,List.map (fun (il,vol,e) -> (il,vol,traverse (mk_block e))) il_vol_e_l, Option.map (fun e -> traverse (mk_block e)) default) } *)
  4993. | TSwitch (cond,el_e_l, default) ->
  4994. { e with eexpr = TSwitch(cond, List.map (fun (el,e) -> (el, traverse (mk_block e))) el_e_l, Option.map (fun e -> traverse (mk_block e)) default) }
  4995. | TWhile (cond,block,flag) ->
  4996. {e with eexpr = TWhile(cond,traverse (mk_block block), flag) }
  4997. | TIf (cond, eif, eelse) ->
  4998. { e with eexpr = TIf(cond, traverse (mk_block eif), Option.map (fun e -> traverse (mk_block e)) eelse) }
  4999. | TFor (v,it,block) ->
  5000. { e with eexpr = TFor(v,it, traverse (mk_block block)) }
  5001. | TFunction (tfunc) ->
  5002. { e with eexpr = TFunction({ tfunc with tf_expr = traverse (mk_block tfunc.tf_expr) }) }
  5003. | _ -> e (* if expression doesn't have a block, we will exit *)
  5004. in
  5005. traverse
  5006. let configure gen (mapping_func:texpr->texpr) =
  5007. let map e = Some(mapping_func e) in
  5008. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  5009. end;;
  5010. (* ******************************************* *)
  5011. (* Casts detection v2 *)
  5012. (* ******************************************* *)
  5013. (*
  5014. Will detect implicit casts and add TCast for them. Since everything is already followed by follow_all, typedefs are considered a new type altogether
  5015. Types shouldn't be cast if:
  5016. * When an instance is being coerced to a superclass or to an implemented interface
  5017. * When anything is being coerced to Dynamic
  5018. edit:
  5019. As a matter of performance, we will also run the type parameters casts in here. Otherwise the exact same computation would have to be performed twice,
  5020. with maybe even some loss of information
  5021. * TAnon / TDynamic will call
  5022. * Type parameter handling will be abstracted
  5023. dependencies:
  5024. Must run before ExpressionUnwrap
  5025. *)
  5026. module CastDetect =
  5027. struct
  5028. let name = "cast_detect_2"
  5029. let priority = solve_deps name [DBefore TypeParams.priority; DBefore ExpressionUnwrap.priority]
  5030. (* ******************************************* *)
  5031. (* ReturnCast *)
  5032. (* ******************************************* *)
  5033. (*
  5034. Cast detection for return types can't be done at CastDetect time, since we need an
  5035. unwrapped expression to make sure we catch all return cast detections. So this module
  5036. is specifically to deal with that, and is configured automatically by CastDetect
  5037. dependencies:
  5038. *)
  5039. module ReturnCast =
  5040. struct
  5041. let name = "return_cast"
  5042. let priority = solve_deps name [DAfter priority; DAfter ExpressionUnwrap.priority]
  5043. let default_implementation gen =
  5044. let rec extract_expr e = match e.eexpr with
  5045. | TParenthesis e
  5046. | TMeta (_,e)
  5047. | TCast(e,_) -> extract_expr e
  5048. | _ -> e
  5049. in
  5050. let current_ret_type = ref None in
  5051. let handle e tto tfrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type tfrom) e in
  5052. let in_value = ref false in
  5053. let rec run e =
  5054. let was_in_value = !in_value in
  5055. in_value := true;
  5056. match e.eexpr with
  5057. | TReturn (eopt) ->
  5058. (* a return must be inside a function *)
  5059. let ret_type = match !current_ret_type with | Some(s) -> s | None -> gen.gcon.error "Invalid return outside function declaration." e.epos; assert false in
  5060. (match eopt with
  5061. | None when not (is_void ret_type) ->
  5062. { e with eexpr = TReturn( Some(null ret_type e.epos)) }
  5063. | None -> e
  5064. | Some eret ->
  5065. { e with eexpr = TReturn( Some(handle (run eret) ret_type eret.etype ) ) })
  5066. | TFunction(tfunc) ->
  5067. let last_ret = !current_ret_type in
  5068. current_ret_type := Some(tfunc.tf_type);
  5069. let ret = Type.map_expr run e in
  5070. current_ret_type := last_ret;
  5071. ret
  5072. | TBlock el ->
  5073. { e with eexpr = TBlock ( List.map (fun e -> in_value := false; run e) el ) }
  5074. | TBinop ( (Ast.OpAssign as op),e1,e2)
  5075. | TBinop ( (Ast.OpAssignOp _ as op),e1,e2) when was_in_value ->
  5076. let e1 = extract_expr (run e1) in
  5077. let r = { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype } in
  5078. handle r e.etype e1.etype
  5079. | TBinop ( (Ast.OpAssign as op),({ eexpr = TField(tf, f) } as e1), e2 )
  5080. | TBinop ( (Ast.OpAssignOp _ as op),({ eexpr = TField(tf, f) } as e1), e2 ) ->
  5081. (match field_access_esp gen (gen.greal_type tf.etype) (f) with
  5082. | FClassField(cl,params,_,_,is_static,actual_t,_) ->
  5083. let actual_t = if is_static then actual_t else apply_params cl.cl_params params actual_t in
  5084. let e1 = extract_expr (run e1) in
  5085. { e with eexpr = TBinop(op, e1, handle (run e2) actual_t e2.etype); etype = e1.etype }
  5086. | _ ->
  5087. let e1 = extract_expr (run e1) in
  5088. { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype }
  5089. )
  5090. | TBinop ( (Ast.OpAssign as op),e1,e2)
  5091. | TBinop ( (Ast.OpAssignOp _ as op),e1,e2) ->
  5092. let e1 = extract_expr (run e1) in
  5093. { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype }
  5094. | _ -> Type.map_expr run e
  5095. in
  5096. run
  5097. let configure gen =
  5098. let map e = Some(default_implementation gen e) in
  5099. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  5100. end;;
  5101. let get_args t = match follow t with
  5102. | TFun(args,ret) -> args,ret
  5103. | _ -> trace (debug_type t); assert false
  5104. let s_path (pack,n) = (String.concat "." (pack @ [n]))
  5105. (*
  5106. Since this function is applied under native-context only, the type paraters will already be changed
  5107. *)
  5108. let map_cls gen also_implements fn super =
  5109. let rec loop c tl =
  5110. if c == super then
  5111. fn c tl
  5112. else (match c.cl_super with
  5113. | None -> false
  5114. | Some (cs,tls) ->
  5115. let tls = gen.greal_type_param (TClassDecl cs) tls in
  5116. loop cs (List.map (apply_params c.cl_params tl) tls)
  5117. ) || (if also_implements then List.exists (fun (cs,tls) ->
  5118. loop cs (List.map (apply_params c.cl_params tl) tls)
  5119. ) c.cl_implements else false)
  5120. in
  5121. loop
  5122. let follow_dyn t = match follow t with
  5123. | TMono _ | TLazy _ -> t_dynamic
  5124. | t -> t
  5125. (*
  5126. this has a slight change from the type.ml version, in which it doesn't
  5127. change a TMono into the other parameter
  5128. *)
  5129. let rec type_eq gen param a b =
  5130. if a == b then
  5131. ()
  5132. else match follow_dyn (gen.greal_type a) , follow_dyn (gen.greal_type b) with
  5133. | TEnum (e1,tl1) , TEnum (e2,tl2) ->
  5134. if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then Type.error [cannot_unify a b];
  5135. List.iter2 (type_eq gen param) tl1 tl2
  5136. | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
  5137. if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then Type.error [cannot_unify a b];
  5138. List.iter2 (type_eq gen param) tl1 tl2
  5139. | TInst (c1,tl1) , TInst (c2,tl2) ->
  5140. if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then Type.error [cannot_unify a b];
  5141. List.iter2 (type_eq gen param) tl1 tl2
  5142. | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
  5143. (try
  5144. type_eq gen param r1 r2;
  5145. List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
  5146. if o1 <> o2 then Type.error [Not_matching_optional n];
  5147. type_eq gen param t1 t2
  5148. ) l1 l2
  5149. with
  5150. Unify_error l -> Type.error (cannot_unify a b :: l))
  5151. | TDynamic a , TDynamic b ->
  5152. type_eq gen param a b
  5153. | TAnon a1, TAnon a2 ->
  5154. (try
  5155. PMap.iter (fun n f1 ->
  5156. try
  5157. let f2 = PMap.find n a2.a_fields in
  5158. if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then Type.error [invalid_kind n f1.cf_kind f2.cf_kind];
  5159. try
  5160. type_eq gen param f1.cf_type f2.cf_type
  5161. with
  5162. Unify_error l -> Type.error (invalid_field n :: l)
  5163. with
  5164. Not_found ->
  5165. if is_closed a2 then Type.error [has_no_field b n];
  5166. if not (link (ref None) b f1.cf_type) then Type.error [cannot_unify a b];
  5167. a2.a_fields <- PMap.add n f1 a2.a_fields
  5168. ) a1.a_fields;
  5169. PMap.iter (fun n f2 ->
  5170. if not (PMap.mem n a1.a_fields) then begin
  5171. if is_closed a1 then Type.error [has_no_field a n];
  5172. if not (link (ref None) a f2.cf_type) then Type.error [cannot_unify a b];
  5173. a1.a_fields <- PMap.add n f2 a1.a_fields
  5174. end;
  5175. ) a2.a_fields;
  5176. with
  5177. Unify_error l -> Type.error (cannot_unify a b :: l))
  5178. | _ , _ ->
  5179. if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then
  5180. ()
  5181. else if a == t_dynamic && param = EqBothDynamic then
  5182. ()
  5183. else
  5184. Type.error [cannot_unify a b]
  5185. let type_iseq gen a b =
  5186. try
  5187. type_eq gen EqStrict a b;
  5188. true
  5189. with
  5190. Unify_error _ -> false
  5191. (* will return true if both arguments are compatible. If it's not the case, a runtime error is very likely *)
  5192. let is_cl_related gen cl tl super superl =
  5193. let is_cl_related cl tl super superl = map_cls gen (gen.guse_tp_constraints || (match cl.cl_kind,super.cl_kind with KTypeParameter _, _ | _,KTypeParameter _ -> false | _ -> true)) (fun _ _ -> true) super cl tl in
  5194. is_cl_related cl tl super superl || is_cl_related super superl cl tl
  5195. let rec is_unsafe_cast gen to_t from_t =
  5196. match (follow to_t, follow from_t) with
  5197. | TInst(cl_to, to_params), TInst(cl_from, from_params) ->
  5198. not (is_cl_related gen cl_from from_params cl_to to_params)
  5199. | TEnum(e_to, _), TEnum(e_from, _) ->
  5200. e_to.e_path <> e_from.e_path
  5201. | TFun _, TFun _ ->
  5202. (* functions are never unsafe cast by default. This behavior might be changed *)
  5203. (* with a later AST pass which will run through TFun to TFun casts *)
  5204. false
  5205. | TMono _, _
  5206. | _, TMono _
  5207. | TDynamic _, _
  5208. | _, TDynamic _ ->
  5209. false
  5210. | TAnon _, _
  5211. | _, TAnon _ ->
  5212. (* anonymous are never unsafe also. *)
  5213. (* Though they will generate a cast, so if this cast is unneeded it's better to avoid them by tweaking gen.greal_type *)
  5214. false
  5215. | TAbstract _, _
  5216. | _, TAbstract _ ->
  5217. (try
  5218. unify from_t to_t;
  5219. false
  5220. with | Unify_error _ ->
  5221. try
  5222. unify to_t from_t; (* still not unsafe *)
  5223. false
  5224. with | Unify_error _ ->
  5225. true)
  5226. | _ -> true
  5227. let unifies tfrom tto = try
  5228. unify tfrom tto;
  5229. true
  5230. with | _ ->
  5231. false
  5232. let do_unsafe_cast gen from_t to_t e =
  5233. let t_path t =
  5234. match t with
  5235. | TInst(cl, _) -> cl.cl_path
  5236. | TEnum(e, _) -> e.e_path
  5237. | TType(t, _) -> t.t_path
  5238. | TAbstract(a, _) -> a.a_path
  5239. | TDynamic _ -> ([], "Dynamic")
  5240. | _ -> raise Not_found
  5241. in
  5242. match gen.gfollow#run_f from_t, gen.gfollow#run_f to_t with
  5243. | TInst({ cl_kind = KTypeParameter tl },_), t2 when List.exists (fun t -> unifies t t2) tl ->
  5244. mk_cast to_t (mk_cast t_dynamic e)
  5245. | _ ->
  5246. let do_default () =
  5247. gen.gon_unsafe_cast to_t e.etype e.epos;
  5248. mk_cast to_t (mk_cast t_dynamic e)
  5249. in
  5250. (* TODO: there really should be a better way to write that *)
  5251. try
  5252. if (Hashtbl.find gen.gsupported_conversions (t_path from_t)) from_t to_t then
  5253. mk_cast to_t e
  5254. else
  5255. do_default()
  5256. with
  5257. | Not_found ->
  5258. try
  5259. if (Hashtbl.find gen.gsupported_conversions (t_path to_t)) from_t to_t then
  5260. mk_cast to_t e
  5261. else
  5262. do_default()
  5263. with
  5264. | Not_found -> do_default()
  5265. (* ****************************** *)
  5266. (* cast handler *)
  5267. (* decides if a cast should be emitted, given a from and a to type *)
  5268. (*
  5269. this function is like a mini unify, without e.g. subtyping, which makes sense
  5270. at the backend level, since most probably Anons and TInst will have a different representation there
  5271. *)
  5272. let rec handle_cast gen e real_to_t real_from_t =
  5273. let do_unsafe_cast () = do_unsafe_cast gen real_from_t real_to_t { e with etype = real_from_t } in
  5274. let to_t, from_t = real_to_t, real_from_t in
  5275. let mk_cast t e =
  5276. match e.eexpr with
  5277. (* TThrow is always typed as Dynamic, we just need to type it accordingly *)
  5278. | TThrow _ -> { e with etype = t }
  5279. | _ -> mk_cast t e
  5280. in
  5281. let e = { e with etype = real_from_t } in
  5282. if try fast_eq real_to_t real_from_t with Invalid_argument("List.for_all2") -> false then e else
  5283. match real_to_t, real_from_t with
  5284. (* string is the only type that can be implicitly converted from any other *)
  5285. | TInst( { cl_path = ([], "String") }, []), _ ->
  5286. mk_cast to_t e
  5287. | TInst(cl_to, params_to), TInst(cl_from, params_from) ->
  5288. let ret = ref None in
  5289. (*
  5290. this is a little confusing:
  5291. we are here mapping classes until we have the same to and from classes, applying the type parameters in each step, so we can
  5292. compare the type parameters;
  5293. If a class is found - meaning that the cl_from can be converted without a cast into cl_to,
  5294. we still need to check their type parameters.
  5295. *)
  5296. ignore (map_cls gen (gen.guse_tp_constraints || (match cl_from.cl_kind,cl_to.cl_kind with KTypeParameter _, _ | _,KTypeParameter _ -> false | _ -> true)) (fun _ tl ->
  5297. try
  5298. (* type found, checking type parameters *)
  5299. List.iter2 (type_eq gen EqStrict) tl params_to;
  5300. ret := Some e;
  5301. true
  5302. with | Unify_error _ ->
  5303. (* type parameters need casting *)
  5304. if gen.ghas_tparam_cast_handler then begin
  5305. (*
  5306. if we are already handling type parameter casts on other part of code (e.g. RealTypeParameters),
  5307. we'll just make a cast to indicate that this place needs type parameter-involved casting
  5308. *)
  5309. ret := Some (mk_cast to_t e);
  5310. true
  5311. end else
  5312. (*
  5313. if not, we're going to check if we only need a simple cast,
  5314. or if we need to first cast into the dynamic version of it
  5315. *)
  5316. try
  5317. List.iter2 (type_eq gen EqRightDynamic) tl params_to;
  5318. ret := Some (mk_cast to_t e);
  5319. true
  5320. with | Unify_error _ ->
  5321. ret := Some (mk_cast to_t (mk_cast (TInst(cl_to, List.map (fun _ -> t_dynamic) params_to)) e));
  5322. true
  5323. ) cl_to cl_from params_from);
  5324. if is_some !ret then
  5325. get !ret
  5326. else if is_cl_related gen cl_from params_from cl_to params_to then
  5327. mk_cast to_t e
  5328. else
  5329. (* potential unsafe cast *)
  5330. (do_unsafe_cast ())
  5331. | TMono _, TMono _
  5332. | TMono _, TDynamic _
  5333. | TDynamic _, TDynamic _
  5334. | TDynamic _, TMono _ ->
  5335. e
  5336. | TMono _, _
  5337. | TDynamic _, _
  5338. | TAnon _, _ when gen.gneeds_box real_from_t ->
  5339. mk_cast to_t e
  5340. | TMono _, _
  5341. | TDynamic _, _ -> e
  5342. | _, TMono _
  5343. | _, TDynamic _ -> mk_cast to_t e
  5344. | TAnon (a_to), TAnon (a_from) ->
  5345. if a_to == a_from then
  5346. e
  5347. else if type_iseq gen to_t from_t then (* FIXME apply unify correctly *)
  5348. e
  5349. else
  5350. mk_cast to_t e
  5351. | _, TAnon(anon) -> (try
  5352. let p2 = match !(anon.a_status) with
  5353. | Statics c -> TInst(c,List.map (fun _ -> t_dynamic) c.cl_params)
  5354. | EnumStatics e -> TEnum(e, List.map (fun _ -> t_dynamic) e.e_params)
  5355. | AbstractStatics a -> TAbstract(a, List.map (fun _ -> t_dynamic) a.a_params)
  5356. | _ -> raise Not_found
  5357. in
  5358. let tclass = match get_type gen ([],"Class") with
  5359. | TAbstractDecl(a) -> a
  5360. | _ -> assert false in
  5361. handle_cast gen e real_to_t (gen.greal_type (TAbstract(tclass, [p2])))
  5362. with | Not_found ->
  5363. mk_cast to_t e)
  5364. | TAbstract (a_to, _), TAbstract(a_from, _) when a_to == a_from ->
  5365. e
  5366. | TAbstract _, TInst({ cl_kind = KTypeParameter _ }, _)
  5367. | TInst({ cl_kind = KTypeParameter _ }, _), TAbstract _ ->
  5368. do_unsafe_cast()
  5369. | TAbstract _, _
  5370. | _, TAbstract _ ->
  5371. (try
  5372. unify from_t to_t;
  5373. mk_cast to_t e
  5374. with | Unify_error _ ->
  5375. try
  5376. unify to_t from_t;
  5377. mk_cast to_t e
  5378. with | Unify_error _ ->
  5379. do_unsafe_cast())
  5380. | TEnum(e_to, []), TEnum(e_from, []) ->
  5381. if e_to == e_from then
  5382. e
  5383. else
  5384. (* potential unsafe cast *)
  5385. (do_unsafe_cast ())
  5386. | TEnum(e_to, params_to), TEnum(e_from, params_from) when e_to.e_path = e_from.e_path ->
  5387. (try
  5388. List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to;
  5389. e
  5390. with
  5391. | Unify_error _ -> do_unsafe_cast ()
  5392. )
  5393. | TEnum(en, params_to), TInst(cl, params_from)
  5394. | TInst(cl, params_to), TEnum(en, params_from) ->
  5395. (* this is here for max compatibility with EnumsToClass module *)
  5396. if en.e_path = cl.cl_path && Meta.has Meta.Class en.e_meta then begin
  5397. (try
  5398. List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to;
  5399. e
  5400. with
  5401. | Invalid_argument("List.iter2") ->
  5402. (*
  5403. this is a hack for RealTypeParams. Since there is no way at this stage to know if the class is the actual
  5404. EnumsToClass derived from the enum, we need to imply from possible ArgumentErrors (because of RealTypeParams interfaces),
  5405. that they would only happen if they were a RealTypeParams created interface
  5406. *)
  5407. e
  5408. | Unify_error _ -> do_unsafe_cast ()
  5409. )
  5410. end else
  5411. do_unsafe_cast ()
  5412. | TType(t_to, params_to), TType(t_from, params_from) when t_to == t_from ->
  5413. if gen.gspecial_needs_cast real_to_t real_from_t then
  5414. (try
  5415. List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to;
  5416. e
  5417. with
  5418. | Unify_error _ -> do_unsafe_cast ()
  5419. )
  5420. else
  5421. e
  5422. | TType(t_to, _), TType(t_from,_) ->
  5423. if gen.gspecial_needs_cast real_to_t real_from_t then
  5424. mk_cast to_t e
  5425. else
  5426. e
  5427. | TType _, _ when gen.gspecial_needs_cast real_to_t real_from_t ->
  5428. mk_cast to_t e
  5429. | _, TType _ when gen.gspecial_needs_cast real_to_t real_from_t ->
  5430. mk_cast to_t e
  5431. (*| TType(t_to, _), TType(t_from, _) ->
  5432. if t_to.t_path = t_from.t_path then
  5433. e
  5434. else if is_unsafe_cast gen real_to_t real_from_t then (* is_unsafe_cast will already follow both *)
  5435. (do_unsafe_cast ())
  5436. else
  5437. mk_cast to_t e*)
  5438. | TType _, _
  5439. | _, TType _ ->
  5440. if is_unsafe_cast gen real_to_t real_from_t then (* is_unsafe_cast will already follow both *)
  5441. (do_unsafe_cast ())
  5442. else
  5443. mk_cast to_t e
  5444. | TAnon anon, _ ->
  5445. if PMap.is_empty anon.a_fields then
  5446. e
  5447. else
  5448. mk_cast to_t e
  5449. | TFun(args, ret), TFun(args2, ret2) ->
  5450. let get_args = List.map (fun (_,_,t) -> t) in
  5451. (try List.iter2 (type_eq gen (EqBothDynamic)) (ret :: get_args args) (ret2 :: get_args args2); e with | Unify_error _ | Invalid_argument("List.iter2") -> mk_cast to_t e)
  5452. | _, _ ->
  5453. do_unsafe_cast ()
  5454. (* end of cast handler *)
  5455. (* ******************* *)
  5456. let is_static_overload c name =
  5457. match c.cl_super with
  5458. | None -> false
  5459. | Some (sup,_) ->
  5460. let rec loop c =
  5461. (PMap.mem name c.cl_statics) || (match c.cl_super with
  5462. | None -> false
  5463. | Some (sup,_) -> loop sup)
  5464. in
  5465. loop sup
  5466. let does_unify a b =
  5467. try
  5468. unify a b;
  5469. true
  5470. with | Unify_error _ -> false
  5471. (* this is a workaround for issue #1743, as FInstance() is returning the incorrect classfield *)
  5472. let rec clean_t t = match follow t with
  5473. | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
  5474. clean_t (Abstract.get_underlying_type a tl)
  5475. | t -> t
  5476. let select_overload gen applied_f overloads types params =
  5477. let rec check_arg arglist elist =
  5478. match arglist, elist with
  5479. | [], [] -> true (* it is valid *)
  5480. | (_,_,TAbstract({ a_path = (["haxe";"extern"],"Rest") }, [t])) :: [], elist ->
  5481. List.for_all (fun (_,_,et) -> Type.type_iseq (clean_t et) (clean_t t)) elist
  5482. | (_,_,t) :: arglist, (_,_,et) :: elist when Type.type_iseq (clean_t et) (clean_t t) ->
  5483. check_arg arglist elist
  5484. | _ -> false
  5485. in
  5486. match follow applied_f with
  5487. | TFun _ ->
  5488. replace_mono applied_f;
  5489. let args, _ = get_fun applied_f in
  5490. let elist = List.rev args in
  5491. let rec check_overload overloads =
  5492. match overloads with
  5493. | (t, cf) :: overloads ->
  5494. let cft = apply_params types params t in
  5495. let cft = monomorphs cf.cf_params cft in
  5496. let args, _ = get_fun cft in
  5497. if check_arg (List.rev args) elist then
  5498. cf,t,false
  5499. else if overloads = [] then
  5500. cf,t,true (* no compatible overload was found *)
  5501. else
  5502. check_overload overloads
  5503. | [] -> assert false
  5504. in
  5505. check_overload overloads
  5506. | _ -> match overloads with (* issue #1742 *)
  5507. | (t,cf) :: [] -> cf,t,true
  5508. | (t,cf) :: _ -> cf,t,false
  5509. | _ -> assert false
  5510. let choose_ctor gen cl tparams etl maybe_empty_t p =
  5511. let ctor, sup, stl = OverloadingConstructor.cur_ctor cl tparams in
  5512. (* get returned stl, with Dynamic as t_empty *)
  5513. let rec get_changed_stl c tl =
  5514. if c == sup then
  5515. tl
  5516. else match c.cl_super with
  5517. | None -> stl
  5518. | Some(sup,stl) -> get_changed_stl sup (List.map (apply_params c.cl_params tl) stl)
  5519. in
  5520. let ret_tparams = List.map (fun t -> match follow t with
  5521. | TDynamic _ | TMono _ -> t_empty
  5522. | _ -> t) tparams in
  5523. let ret_stl = get_changed_stl cl ret_tparams in
  5524. let ctors = ctor :: ctor.cf_overloads in
  5525. List.iter replace_mono etl;
  5526. (* first filter out or select outright maybe_empty *)
  5527. let ctors, is_overload = match etl, maybe_empty_t with
  5528. | [t], Some empty_t ->
  5529. let count = ref 0 in
  5530. let is_empty_call = Type.type_iseq t empty_t in
  5531. let ret = List.filter (fun cf -> match follow cf.cf_type with
  5532. (* | TFun([_,_,t],_) -> incr count; true *)
  5533. | TFun([_,_,t],_) ->
  5534. replace_mono t; incr count; is_empty_call = (Type.type_iseq t empty_t)
  5535. | _ -> false) ctors in
  5536. ret, !count > 1
  5537. | _ ->
  5538. let len = List.length etl in
  5539. let ret = List.filter (fun cf -> List.length (fst (get_fun cf.cf_type)) = len) ctors in
  5540. ret, (match ret with | _ :: [] -> false | _ -> true)
  5541. in
  5542. let rec check_arg arglist elist =
  5543. match arglist, elist with
  5544. | [], [] -> true
  5545. | (_,_,t) :: arglist, et :: elist -> (try
  5546. let t = run_follow gen t in
  5547. unify et t;
  5548. check_arg arglist elist
  5549. with | Unify_error el ->
  5550. (* List.iter (fun el -> gen.gcon.warning (Typecore.unify_error_msg (print_context()) el) p) el; *)
  5551. false)
  5552. | _ ->
  5553. false
  5554. in
  5555. let rec check_cf cf =
  5556. let t = apply_params sup.cl_params stl cf.cf_type in
  5557. replace_mono t;
  5558. let args, _ = get_fun t in
  5559. check_arg args etl
  5560. in
  5561. match is_overload, ctors with
  5562. | false, [c] ->
  5563. false, c, sup, ret_stl
  5564. | _ ->
  5565. is_overload, List.find check_cf ctors, sup, ret_stl
  5566. let change_rest tfun elist =
  5567. let rec loop acc arglist elist = match arglist, elist with
  5568. | (_,_,TAbstract({ a_path = (["haxe";"extern"],"Rest") },[t])) :: [], elist ->
  5569. List.rev (List.map (fun _ -> "rest",false,t) elist @ acc)
  5570. | (n,o,t) :: arglist, _ :: elist ->
  5571. loop ((n,o,t) :: acc) arglist elist
  5572. | _, _ ->
  5573. List.rev acc
  5574. in
  5575. let args,ret = get_fun tfun in
  5576. TFun(loop [] args elist, ret)
  5577. (*
  5578. Type parameter handling
  5579. It will detect if/what type parameters were used, and call the cast handler
  5580. It will handle both TCall(TField) and TCall by receiving a texpr option field: e
  5581. Also it will transform the type parameters with greal_type_param and make
  5582. handle_impossible_tparam - should cases where the type parameter is impossible to be determined from the called parameters be Dynamic?
  5583. e.g. static function test<T>():T {}
  5584. *)
  5585. (* match e.eexpr with | TCall( ({ eexpr = TField(ef, f) }) as e1, elist ) -> *)
  5586. let handle_type_parameter gen e e1 ef ~clean_ef ~overloads_cast_to_base f elist calls_parameters_explicitly =
  5587. (* the ONLY way to know if this call has parameters is to analyze the calling field. *)
  5588. (* To make matters a little worse, on both C# and Java only in some special cases that type parameters will be used *)
  5589. (* Namely, when using reflection type parameters are useless, of course. This also includes anonymous types *)
  5590. (* this will have to be handled by gparam_func_call *)
  5591. let return_var efield =
  5592. match e with
  5593. | None ->
  5594. efield
  5595. | Some ecall ->
  5596. match follow efield.etype with
  5597. | TFun(_,ret) ->
  5598. (* closures will be handled by the closure handler. So we will just hint what's the expected type *)
  5599. (* FIXME: should closures have also its arguments cast correctly? In the current implementation I think not. TO_REVIEW *)
  5600. handle_cast gen { ecall with eexpr = TCall(efield, elist) } (gen.greal_type ecall.etype) ret
  5601. | _ ->
  5602. { ecall with eexpr = TCall(efield, elist) }
  5603. in
  5604. let real_type = gen.greal_type ef.etype in
  5605. (* this part was rewritten at roughly r6477 in order to correctly support overloads *)
  5606. (match field_access_esp gen real_type (f) with
  5607. | FClassField (cl, params, _, cf, is_static, actual_t, declared_t) when e <> None && (cf.cf_kind = Method MethNormal || cf.cf_kind = Method MethInline) ->
  5608. (* C# target changes params with a real_type function *)
  5609. let params = match follow clean_ef.etype with
  5610. | TInst(_,params) -> params
  5611. | _ -> params
  5612. in
  5613. let ecall = get e in
  5614. let ef = ref ef in
  5615. let is_overload = cf.cf_overloads <> [] || Meta.has Meta.Overload cf.cf_meta || (is_static && is_static_overload cl (field_name f)) in
  5616. let cf, actual_t, error = match is_overload with
  5617. | false ->
  5618. (* since actual_t from FClassField already applies greal_type, we're using the get_overloads helper to get this info *)
  5619. let t = if cf.cf_params = [] then (* this if statement must be eliminated - it's a workaround for #3516 + infer params. *)
  5620. actual_t
  5621. else
  5622. declared_t
  5623. in
  5624. cf,t,false
  5625. | true ->
  5626. let (cf, actual_t, error), is_static = match f with
  5627. | FInstance(c,_,cf) | FClosure(Some (c,_),cf) ->
  5628. (* get from overloads *)
  5629. (* FIXME: this is a workaround for issue #1743 . Uncomment this code after it was solved *)
  5630. (* let t, cf = List.find (fun (t,cf2) -> cf == cf2) (Typeload.get_overloads cl (field_name f)) in *)
  5631. (* cf, t, false *)
  5632. select_overload gen e1.etype (Typeload.get_overloads cl (field_name f)) cl.cl_params params, false
  5633. | FStatic(c,f) ->
  5634. (* workaround for issue #1743 *)
  5635. (* f,f.cf_type, false *)
  5636. select_overload gen e1.etype ((f.cf_type,f) :: List.map (fun f -> f.cf_type,f) f.cf_overloads) [] [], true
  5637. | _ ->
  5638. gen.gcon.warning "Overloaded classfield typed as anonymous" ecall.epos;
  5639. (cf, actual_t, true), true
  5640. in
  5641. if not (is_static || error) then match find_first_declared_field gen cl ~exact_field:{ cf with cf_type = actual_t } cf.cf_name with
  5642. | Some(cf_orig,actual_t,_,_,declared_cl,tl,tlch) ->
  5643. let rec is_super e = match e.eexpr with
  5644. | TConst TSuper -> true
  5645. | TParenthesis p | TMeta(_,p) -> is_super p
  5646. | _ -> false
  5647. in
  5648. if declared_cl != cl && overloads_cast_to_base && not (is_super !ef) then begin
  5649. let pos = (!ef).epos in
  5650. ef := {
  5651. eexpr = TCall(
  5652. { eexpr = TLocal(alloc_var "__as__" t_dynamic); etype = t_dynamic; epos = pos },
  5653. [!ef]);
  5654. etype = TInst(declared_cl,List.map (apply_params cl.cl_params params) tl);
  5655. epos = pos
  5656. }
  5657. end;
  5658. { cf_orig with cf_name = cf.cf_name },actual_t,false
  5659. | None ->
  5660. gen.gcon.warning "Cannot find matching overload" ecall.epos;
  5661. cf, actual_t, true
  5662. else
  5663. cf,actual_t,error
  5664. in
  5665. (* take off Rest param *)
  5666. let actual_t = change_rest actual_t elist in
  5667. (* set the real (selected) class field *)
  5668. let f = match f with
  5669. | FInstance(c,tl,_) -> FInstance(c,tl,cf)
  5670. | FClosure(c,_) -> FClosure(c,cf)
  5671. | FStatic(c,_) -> FStatic(c,cf)
  5672. | f -> f
  5673. in
  5674. let error = error || (match follow actual_t with | TFun _ -> false | _ -> true) in
  5675. if error then (* if error, ignore arguments *)
  5676. if is_void ecall.etype then
  5677. { ecall with eexpr = TCall({ e1 with eexpr = TField(!ef, f) }, elist ) }
  5678. else
  5679. mk_cast ecall.etype { ecall with eexpr = TCall({ e1 with eexpr = TField(!ef, f) }, elist ) }
  5680. else begin
  5681. (* infer arguments *)
  5682. (* let called_t = TFun(List.map (fun e -> "arg",false,e.etype) elist, ecall.etype) in *)
  5683. let called_t = match follow e1.etype with | TFun _ -> e1.etype | _ -> TFun(List.map (fun e -> "arg",false,e.etype) elist, ecall.etype) in (* workaround for issue #1742 *)
  5684. let called_t = change_rest called_t elist in
  5685. let fparams = TypeParams.infer_params gen ecall.epos (get_fun (apply_params cl.cl_params params actual_t)) (get_fun called_t) cf.cf_params calls_parameters_explicitly in
  5686. (* get what the backend actually sees *)
  5687. (* actual field's function *)
  5688. let actual_t = get_real_fun gen actual_t in
  5689. let real_params = gen.greal_type_param (TClassDecl cl) params in
  5690. let function_t = apply_params cl.cl_params real_params actual_t in
  5691. let real_fparams = if calls_parameters_explicitly then
  5692. gen.greal_type_param (TClassDecl cl) fparams
  5693. else
  5694. gen.greal_type_param (TClassDecl cl) (TypeParams.infer_params gen ecall.epos (get_fun function_t) (get_fun (get_real_fun gen called_t)) cf.cf_params calls_parameters_explicitly) in
  5695. let function_t = get_real_fun gen (apply_params cf.cf_params real_fparams function_t) in
  5696. let args_ft, ret_ft = get_fun function_t in
  5697. (* applied function *)
  5698. let applied = elist in
  5699. (* check types list *)
  5700. let new_ecall, elist = try
  5701. let elist = List.map2 (fun applied (_,_,funct) ->
  5702. match is_overload, applied.eexpr with
  5703. | true, TConst TNull ->
  5704. mk_cast (gen.greal_type funct) applied
  5705. | true, _ -> (* when not (type_iseq gen (gen.greal_type applied.etype) funct) -> *)
  5706. let ret = handle_cast gen applied (funct) (gen.greal_type applied.etype) in
  5707. (match ret.eexpr with
  5708. | TCast _ -> ret
  5709. | _ -> mk_cast (funct) ret)
  5710. | _ ->
  5711. handle_cast gen applied (funct) (gen.greal_type applied.etype)
  5712. ) applied args_ft in
  5713. { ecall with
  5714. eexpr = TCall(
  5715. { e1 with eexpr = TField(!ef, f) },
  5716. elist);
  5717. }, elist
  5718. with | Invalid_argument("List.map2") ->
  5719. gen.gcon.warning ("This expression may be invalid" ) ecall.epos;
  5720. { ecall with eexpr = TCall({ e1 with eexpr = TField(!ef, f) }, elist) }, elist
  5721. in
  5722. let new_ecall = if fparams <> [] then gen.gparam_func_call new_ecall { e1 with eexpr = TField(!ef, f) } fparams elist else new_ecall in
  5723. let ret = handle_cast gen new_ecall (gen.greal_type ecall.etype) (gen.greal_type ret_ft) in
  5724. (match gen.gcon.platform, cf.cf_params, ret.eexpr with
  5725. | _, _, TCast _ -> ret
  5726. | Java, _ :: _, _ ->
  5727. (* this is a workaround for a javac openjdk issue with unused type parameters and return type inference *)
  5728. (* see more at issue #3123 *)
  5729. mk_cast (gen.greal_type ret_ft) new_ecall
  5730. | _ -> ret)
  5731. end
  5732. | FClassField (cl,params,_,{ cf_kind = (Method MethDynamic | Var _) },_,actual_t,_) ->
  5733. (* if it's a var, we will just try to apply the class parameters that have been changed with greal_type_param *)
  5734. let t = apply_params cl.cl_params (gen.greal_type_param (TClassDecl cl) params) (gen.greal_type actual_t) in
  5735. return_var (handle_cast gen { e1 with eexpr = TField(ef, f) } (gen.greal_type e1.etype) (gen.greal_type t))
  5736. | FClassField (cl,params,_,cf,_,actual_t,_) ->
  5737. return_var (handle_cast gen { e1 with eexpr = TField({ ef with etype = t_dynamic }, f) } e1.etype t_dynamic) (* force dynamic and cast back to needed type *)
  5738. | FEnumField (en, efield, true) ->
  5739. let ecall = match e with | None -> trace (field_name f); trace efield.ef_name; gen.gcon.error "This field should be called immediately" ef.epos; assert false | Some ecall -> ecall in
  5740. (match en.e_params with
  5741. (*
  5742. | [] ->
  5743. let args, ret = get_args (efield.ef_type) in
  5744. let ef = { ef with eexpr = TTypeExpr( TEnumDecl en ); etype = TEnum(en, []) } in
  5745. handle_cast gen { ecall with eexpr = TCall({ e1 with eexpr = TField(ef, FEnum(en, efield)) }, List.map2 (fun param (_,_,t) -> handle_cast gen param (gen.greal_type t) (gen.greal_type param.etype)) elist args) } (gen.greal_type ecall.etype) (gen.greal_type ret)
  5746. *)
  5747. | _ ->
  5748. let pt = match e with | None -> real_type | Some _ -> snd (get_fun e1.etype) in
  5749. let _params = match follow pt with | TEnum(_, p) -> p | _ -> gen.gcon.warning (debug_expr e1) e1.epos; assert false in
  5750. let args, ret = get_args efield.ef_type in
  5751. let actual_t = TFun(List.map (fun (n,o,t) -> (n,o,gen.greal_type t)) args, gen.greal_type ret) in
  5752. (*
  5753. because of differences on how <Dynamic> is handled on the platforms, this is a hack to be able to
  5754. correctly use class field type parameters with RealTypeParams
  5755. *)
  5756. let cf_params = List.map (fun t -> match follow t with | TDynamic _ -> t_empty | _ -> t) _params in
  5757. let t = apply_params en.e_params (gen.greal_type_param (TEnumDecl en) cf_params) actual_t in
  5758. let t = apply_params efield.ef_params (List.map (fun _ -> t_dynamic) efield.ef_params) t in
  5759. let args, ret = get_args t in
  5760. let elist = List.map2 (fun param (_,_,t) -> handle_cast gen (param) (gen.greal_type t) (gen.greal_type param.etype)) elist args in
  5761. let e1 = { e1 with eexpr = TField({ ef with eexpr = TTypeExpr( TEnumDecl en ); etype = TEnum(en, _params) }, FEnum(en, efield) ) } in
  5762. let new_ecall = gen.gparam_func_call ecall e1 _params elist in
  5763. handle_cast gen new_ecall (gen.greal_type ecall.etype) (gen.greal_type ret)
  5764. )
  5765. | FEnumField _ when is_some e -> assert false
  5766. | FEnumField (en,efield,_) ->
  5767. return_var { e1 with eexpr = TField({ ef with eexpr = TTypeExpr( TEnumDecl en ); },FEnum(en,efield)) }
  5768. (* no target by date will uses this.so this code may not be correct at all *)
  5769. | FAnonField cf ->
  5770. let t = gen.greal_type cf.cf_type in
  5771. return_var (handle_cast gen { e1 with eexpr = TField(ef, f) } (gen.greal_type e1.etype) t)
  5772. | FNotFound
  5773. | FDynamicField _ ->
  5774. if is_some e then
  5775. return_var { e1 with eexpr = TField(ef, f) }
  5776. else
  5777. return_var (handle_cast gen { e1 with eexpr = TField({ ef with etype = t_dynamic }, f) } e1.etype t_dynamic) (* force dynamic and cast back to needed type *)
  5778. )
  5779. (* end of type parameter handling *)
  5780. (* ****************************** *)
  5781. (** overloads_cast_to_base argument will cast overloaded function types to the class that declared it. **)
  5782. (** This is necessary for C#, and if true, will require the target to implement __as__, as a `quicker` form of casting **)
  5783. let default_implementation gen ?(native_string_cast = true) ?(overloads_cast_to_base = false) maybe_empty_t calls_parameters_explicitly =
  5784. let handle e t1 t2 = handle_cast gen e (gen.greal_type t1) (gen.greal_type t2) in
  5785. let in_value = ref false in
  5786. let rec clean_cast e = match e.eexpr with
  5787. | TCast(e,_) -> clean_cast e
  5788. | TParenthesis(e) | TMeta(_,e) -> clean_cast e
  5789. | _ -> e
  5790. in
  5791. let get_abstract_impl t = match t with
  5792. | TAbstract(a,pl) when not (Meta.has Meta.CoreType a.a_meta) ->
  5793. Abstract.get_underlying_type a pl
  5794. | t -> t
  5795. in
  5796. let rec is_abstract_to_struct t = match t with
  5797. | TAbstract(a,pl) when not (Meta.has Meta.CoreType a.a_meta) ->
  5798. is_abstract_to_struct (Abstract.get_underlying_type a pl)
  5799. | TInst(c,_) when Meta.has Meta.Struct c.cl_meta ->
  5800. true
  5801. | _ -> false
  5802. in
  5803. let rec run ?(just_type = false) e =
  5804. let handle = if not just_type then handle else fun e t1 t2 -> { e with etype = gen.greal_type t2 } in
  5805. let was_in_value = !in_value in
  5806. in_value := true;
  5807. match e.eexpr with
  5808. | TConst ( TInt _ | TFloat _ | TBool _ as const ) ->
  5809. (* take off any Null<> that it may have *)
  5810. let t = follow (run_follow gen e.etype) in
  5811. (* do not allow constants typed as Single - need to cast them *)
  5812. let real_t = match const with
  5813. | TInt _ -> gen.gcon.basic.tint
  5814. | TFloat _ -> gen.gcon.basic.tfloat
  5815. | TBool _ -> gen.gcon.basic.tbool
  5816. | _ -> assert false
  5817. in
  5818. handle e t real_t
  5819. | TCast( { eexpr = TConst TNull }, _ ) ->
  5820. { e with eexpr = TConst TNull }
  5821. | TCast( { eexpr = TCall( { eexpr = TLocal { v_name = "__delegate__" } } as local, [del] ) } as e2, _) ->
  5822. { e with eexpr = TCast({ e2 with eexpr = TCall(local, [Type.map_expr run del]) }, None) }
  5823. | TBinop ( (Ast.OpAssign | Ast.OpAssignOp _ as op), e1, e2 ) ->
  5824. let e1 = run ~just_type:true e1 in
  5825. let e2 = handle (run e2) e1.etype e2.etype in
  5826. { e with eexpr = TBinop(op, clean_cast e1, e2) }
  5827. | TBinop ( (Ast.OpShl | Ast.OpShr | Ast.OpUShr as op), e1, e2 ) ->
  5828. let e1 = run e1 in
  5829. let e2 = handle (run e2) (gen.gcon.basic.tint) e2.etype in
  5830. { e with eexpr = TBinop(op, e1, e2) }
  5831. | TField(ef, f) ->
  5832. handle_type_parameter gen None e (run ef) ~clean_ef:ef ~overloads_cast_to_base:overloads_cast_to_base f [] calls_parameters_explicitly
  5833. | TArrayDecl el ->
  5834. let et = e.etype in
  5835. let base_type = match follow et with
  5836. | TInst({ cl_path = ([], "Array") } as cl, bt) -> gen.greal_type_param (TClassDecl cl) bt
  5837. | _ ->
  5838. gen.gcon.warning (debug_type et) e.epos;
  5839. (match gen.gcurrent_class with
  5840. | Some cl -> print_endline (path_s cl.cl_path)
  5841. | _ -> ());
  5842. assert false
  5843. in
  5844. let base_type = List.hd base_type in
  5845. { e with eexpr = TArrayDecl( List.map (fun e -> handle (run e) base_type e.etype) el ); etype = et }
  5846. | TCall ({ eexpr = TLocal { v_name = "__array__" } } as arr_local, el) ->
  5847. let et = e.etype in
  5848. let base_type = match follow et with
  5849. | TInst(cl, bt) -> gen.greal_type_param (TClassDecl cl) bt
  5850. | _ -> assert false
  5851. in
  5852. let base_type = List.hd base_type in
  5853. { e with eexpr = TCall(arr_local, List.map (fun e -> handle (run e) base_type e.etype) el ); etype = et }
  5854. | TCall( ({ eexpr = TLocal v } as local), params ) when String.get v.v_name 0 = '_' && String.get v.v_name 1 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name ->
  5855. { e with eexpr = TCall(local, List.map (fun e -> (match e.eexpr with TBlock _ -> in_value := false | _ -> ()); run e) params) }
  5856. | TCall( ({ eexpr = TField(ef, f) }) as e1, elist ) ->
  5857. handle_type_parameter gen (Some e) (e1) (run ef) ~clean_ef:ef ~overloads_cast_to_base:overloads_cast_to_base f (List.map run elist) calls_parameters_explicitly
  5858. (* the TNew and TSuper code was modified at r6497 *)
  5859. | TCall( { eexpr = TConst TSuper } as ef, eparams ) ->
  5860. let cl, tparams = match follow ef.etype with
  5861. | TInst(cl,p) ->
  5862. cl,p
  5863. | _ -> assert false in
  5864. (try
  5865. let is_overload, cf, sup, stl = choose_ctor gen cl tparams (List.map (fun e -> e.etype) eparams) maybe_empty_t e.epos in
  5866. let handle e t1 t2 =
  5867. if is_overload then
  5868. let ret = handle e t1 t2 in
  5869. match ret.eexpr with
  5870. | TCast _ -> ret
  5871. | _ -> mk_cast (gen.greal_type t1) e
  5872. else
  5873. handle e t1 t2
  5874. in
  5875. let stl = gen.greal_type_param (TClassDecl sup) stl in
  5876. let args, _ = get_fun (apply_params sup.cl_params stl cf.cf_type) in
  5877. let eparams = List.map2 (fun e (_,_,t) ->
  5878. handle (run e) t e.etype
  5879. ) eparams args in
  5880. { e with eexpr = TCall(ef, eparams) }
  5881. with | Not_found ->
  5882. gen.gcon.warning "No overload found for this constructor call" e.epos;
  5883. { e with eexpr = TCall(ef, List.map run eparams) })
  5884. | TCall (ef, eparams) ->
  5885. (match ef.etype with
  5886. | TFun(p, ret) ->
  5887. handle ({ e with eexpr = TCall(run ef, List.map2 (fun param (_,_,t) -> handle (run param) t param.etype) eparams p) }) e.etype ret
  5888. | _ -> Type.map_expr run e
  5889. )
  5890. (* the TNew and TSuper code was modified at r6497 *)
  5891. | TNew ({ cl_kind = KTypeParameter _ }, _, _) ->
  5892. Type.map_expr run e
  5893. | TNew (cl, tparams, eparams) -> (try
  5894. let is_overload, cf, sup, stl = choose_ctor gen cl tparams (List.map (fun e -> e.etype) eparams) maybe_empty_t e.epos in
  5895. let handle e t1 t2 =
  5896. if is_overload then
  5897. let ret = handle e t1 t2 in
  5898. match ret.eexpr with
  5899. | TCast _ -> ret
  5900. | _ -> mk_cast (gen.greal_type t1) e
  5901. else
  5902. handle e t1 t2
  5903. in
  5904. let stl = gen.greal_type_param (TClassDecl sup) stl in
  5905. let args, _ = get_fun (apply_params sup.cl_params stl cf.cf_type) in
  5906. let eparams = List.map2 (fun e (_,_,t) ->
  5907. handle (run e) t e.etype
  5908. ) eparams args in
  5909. { e with eexpr = TNew(cl, tparams, eparams) }
  5910. with | Not_found ->
  5911. gen.gcon.warning "No overload found for this constructor call" e.epos;
  5912. { e with eexpr = TNew(cl, tparams, List.map run eparams) })
  5913. | TArray(arr, idx) ->
  5914. let arr_etype = match follow arr.etype with
  5915. | (TInst _ as t) -> t
  5916. | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
  5917. follow (Abstract.get_underlying_type a pl)
  5918. | t -> t in
  5919. let idx = match gen.greal_type idx.etype with
  5920. | TAbstract({ a_path = [],"Int" },_) -> run idx
  5921. | _ -> match handle (run idx) gen.gcon.basic.tint (gen.greal_type idx.etype) with
  5922. | ({ eexpr = TCast _ } as idx) -> idx
  5923. | idx -> mk_cast gen.gcon.basic.tint idx
  5924. in
  5925. let e = { e with eexpr = TArray(run arr, idx) } in
  5926. (* get underlying class (if it's a class *)
  5927. (match arr_etype with
  5928. | TInst(cl, params) ->
  5929. (* see if it implements ArrayAccess *)
  5930. (match cl.cl_array_access with
  5931. | None -> e
  5932. | Some t ->
  5933. (* if it does, apply current parameters (and change them) *)
  5934. (* let real_t = apply_params_internal (List.map (gen.greal_type_param (TClassDecl cl))) cl params t in *)
  5935. let param = apply_params cl.cl_params (gen.greal_type_param (TClassDecl cl) params) t in
  5936. let real_t = apply_params cl.cl_params params param in
  5937. (* see if it needs a cast *)
  5938. handle (e) (gen.greal_type e.etype) (gen.greal_type real_t)
  5939. )
  5940. | _ -> Type.map_expr run e)
  5941. | TVar (v, eopt) ->
  5942. { e with eexpr = TVar (v, match eopt with
  5943. | None -> eopt
  5944. | Some e -> Some( handle (run e) v.v_type e.etype ))
  5945. }
  5946. (* FIXME deal with in_value when using other statements that may not have a TBlock wrapped on them *)
  5947. | TIf (econd, ethen, Some(eelse)) when was_in_value ->
  5948. { e with eexpr = TIf (handle (run econd) gen.gcon.basic.tbool econd.etype, handle (run ethen) e.etype ethen.etype, Some( handle (run eelse) e.etype eelse.etype ) ) }
  5949. | TIf (econd, ethen, eelse) ->
  5950. { e with eexpr = TIf (handle (run econd) gen.gcon.basic.tbool econd.etype, (in_value := false; run (mk_block ethen)), Option.map (fun e -> in_value := false; run (mk_block e)) eelse) }
  5951. | TWhile (econd, e1, flag) ->
  5952. { e with eexpr = TWhile (handle (run econd) gen.gcon.basic.tbool econd.etype, (in_value := false; run (mk_block e1)), flag) }
  5953. | TSwitch (cond, el_e_l, edef) ->
  5954. { e with eexpr = TSwitch(run cond, List.map (fun (el,e) -> (List.map run el, (in_value := false; run (mk_block e)))) el_e_l, Option.map (fun e -> in_value := false; run (mk_block e)) edef) }
  5955. (* | TMatch (cond, en, il_vl_e_l, edef) ->
  5956. { e with eexpr = TMatch(run cond, en, List.map (fun (il, vl, e) -> (il, vl, run (mk_block e))) il_vl_e_l, Option.map (fun e -> run (mk_block e)) edef) } *)
  5957. | TFor (v,cond,e1) ->
  5958. { e with eexpr = TFor(v, run cond, (in_value := false; run (mk_block e1))) }
  5959. | TTry (e, ve_l) ->
  5960. { e with eexpr = TTry((in_value := false; run (mk_block e)), List.map (fun (v,e) -> in_value := false; (v, run (mk_block e))) ve_l) }
  5961. | TBlock el ->
  5962. let i = ref 0 in
  5963. let len = List.length el in
  5964. { e with eexpr = TBlock ( List.map (fun e ->
  5965. incr i;
  5966. if !i <> len || not was_in_value then
  5967. in_value := false;
  5968. run e
  5969. ) el ) }
  5970. | TCast (expr, md) when is_void (follow e.etype) ->
  5971. run expr
  5972. | TCast (expr, md) ->
  5973. let rec get_null e =
  5974. match e.eexpr with
  5975. | TConst TNull -> Some e
  5976. | TParenthesis e | TMeta(_,e) -> get_null e
  5977. | _ -> None
  5978. in
  5979. (match get_null expr with
  5980. | Some enull ->
  5981. if gen.gcon.platform = Cs then
  5982. { enull with etype = gen.greal_type e.etype }
  5983. else
  5984. mk_cast (gen.greal_type e.etype) enull
  5985. | _ when is_abstract_to_struct expr.etype && type_iseq gen e.etype (get_abstract_impl expr.etype) ->
  5986. run { expr with etype = expr.etype }
  5987. | _ ->
  5988. match gen.greal_type e.etype, gen.greal_type expr.etype with
  5989. | (TInst(c,tl) as tinst1), TAbstract({ a_path = ["cs"],"Pointer" }, [tinst2]) when type_iseq gen tinst1 (gen.greal_type tinst2) ->
  5990. run expr
  5991. | _ ->
  5992. let last_unsafe = gen.gon_unsafe_cast in
  5993. gen.gon_unsafe_cast <- (fun t t2 pos -> ());
  5994. let ret = handle (run expr) e.etype expr.etype in
  5995. gen.gon_unsafe_cast <- last_unsafe;
  5996. match ret.eexpr with
  5997. | TCast _ -> { ret with etype = gen.greal_type e.etype }
  5998. | _ -> { e with eexpr = TCast(ret,md); etype = gen.greal_type e.etype }
  5999. )
  6000. (*| TCast _ ->
  6001. (* if there is already a cast, we should skip this cast check *)
  6002. Type.map_expr run e*)
  6003. | TFunction f ->
  6004. in_value := false;
  6005. Type.map_expr run e
  6006. | _ -> Type.map_expr run e
  6007. in
  6008. run
  6009. let configure gen (mapping_func:texpr->texpr) =
  6010. gen.ghandle_cast <- (fun tto tfrom expr -> handle_cast gen expr (gen.greal_type tto) (gen.greal_type tfrom));
  6011. let map e = Some(mapping_func e) in
  6012. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map;
  6013. ReturnCast.configure gen
  6014. end;;
  6015. (* ******************************************* *)
  6016. (* Reflection-enabling Class fields *)
  6017. (* ******************************************* *)
  6018. (*
  6019. This is the most hardcore codegen part of the code. There's much to improve so this code can be more readable, but at least it's running correctly right now! This will be improved. (TODO)
  6020. This module will create class fields that enable reflection for targets that have a slow or inexistent reflection abilities. Because of the similarity
  6021. of strategies between what should have been different modules, they are all unified in this reflection-enabling class fields.
  6022. They include:
  6023. * Get(isStatic, throwErrors, isCheck) / Set fields . Remember to allow implements Dynamic also.
  6024. * Invoke fields(isStatic) -> You need to configure how many invoke_field fields there will be. + invokeDynamic
  6025. * Has field -> parameter in get field that returns __undefined__ if it doesn't exist.
  6026. * GetType -> return the current Class<> / Enum<>
  6027. * Fields(isStatic) -> returns all the fields / static fields. Remember to allow implements Dynamic also
  6028. * Create(arguments array), CreateEmpty - calls new() or create empty
  6029. * getInstanceFields / getClassFields -> show even function fields, everything!
  6030. * deleteField -> only for implements Dynamic
  6031. for enums:
  6032. * createEnum -> invokeField for classes
  6033. * createEnumIndex -> use invokeField as well, and use numbers e.g. "0", "1", "2" .... For this, use "@:alias" metadata
  6034. * getEnumConstructs -> fields()
  6035. need to be solved outside:
  6036. * getEnumName
  6037. * enumIndex
  6038. *
  6039. need to be solved by haxe code:
  6040. * enumParameters -> for (field in Reflect.fields(enum)) arr.push(Reflect.field(enum, field))
  6041. Standard:
  6042. if a class contains a @:$enum metadata, it's treated as a converted enum to class
  6043. Optimizations:
  6044. * if optimize is true, all fields will be hashed by the same hashing function as neko (31 bits int : always positive). Every function that expects a string for the field will expect also an int, for the hash
  6045. a string (which is nullable for compile-time hashes) + an int.
  6046. At compile-time, a collision will throw an error (like neko).
  6047. At runtime, a collision will make a negative int. Negative ints will always resolve to a special Hash<> field which takes a string.
  6048. * if optimize is true, Reflect.field/setField will be replaced by either the runtime version (with already hashed string), either by the own .Field()/.SetField() HxObject's version,
  6049. if the type is detected to already be hxgen
  6050. * TODO: if for() optimization for arrays is disabled, we can replace for(field in Reflect.fields(obj)) to:
  6051. for (field in ( (Std.is(obj, HxObject) ? ((HxObject)obj).Fields() : Reflect.fields(obj)) )) // no array copying . for further optimization this could be guaranteed to return
  6052. the already hashed fields.
  6053. Mappings:
  6054. * if create Dynamic class is true, TObjectDecl will be mapped to new DynamicClass(fields, [hashedFields], values)
  6055. *
  6056. dependencies:
  6057. There is no big dependency from this target. Though it should be a syntax filter, mainly one of the first so most expression generation has already been done,
  6058. while the AST has its meaning close to haxe's.
  6059. Should run before InitFunction so it detects variables containing expressions as "always-execute" expressions, even when using CreateEmpty
  6060. * Must run before switch() syntax changes
  6061. *)
  6062. open ClosuresToClass;;
  6063. module ReflectionCFs =
  6064. struct
  6065. let name = "reflection_cfs"
  6066. type rcf_ctx =
  6067. {
  6068. rcf_gen : generator_ctx;
  6069. rcf_ft : ClosuresToClass.closures_ctx;
  6070. rcf_optimize : bool;
  6071. mutable rcf_float_special_case : bool;
  6072. mutable rcf_object_iface : tclass;
  6073. mutable rcf_create_getsetinvoke_fields : bool;
  6074. (* should we create the get type (get Class)? *)
  6075. mutable rcf_create_get_type : bool;
  6076. (* should we handle implements dynamic? *)
  6077. mutable rcf_handle_impl_dynamic : bool;
  6078. (*
  6079. create_dyn_overloading_ctor :
  6080. when creating the implements dynamic code, we can also create a special constructor for
  6081. the actual DynamicObject class, which will receive all its <implements Dynamic> fields from the code outside.
  6082. Note that this will only work on targets that support overloading contrstuctors, as any class that extends
  6083. our DynamicObject will have an empty super() call
  6084. *)
  6085. mutable rcf_create_dyn_ctor : bool;
  6086. mutable rcf_max_func_arity : int;
  6087. (*
  6088. the hash lookup function. can be an inlined expr or simply a function call.
  6089. its only needed features is that it should return the index of the key if found, and the
  6090. complement of the index of where it should be inserted if not found (Ints).
  6091. hash->hash_array->length->returning expression
  6092. *)
  6093. mutable rcf_hash_function : texpr->texpr->texpr->texpr;
  6094. mutable rcf_lookup_function : texpr->texpr;
  6095. (* hash_array->length->pos->value *)
  6096. mutable rcf_insert_function : texpr->texpr->texpr->texpr->texpr;
  6097. (* hash_array->length->pos->value *)
  6098. mutable rcf_remove_function : texpr->texpr->texpr->texpr;
  6099. (*
  6100. class_cl is the real class for Class<> instances.
  6101. In the current implementation, due to some targets' limitations, (in particular, Java),
  6102. we have to use an empty object so we can access its virtual mehtods.
  6103. FIXME find a better way to create Class<> objects in a performant way
  6104. *)
  6105. mutable rcf_class_cl : tclass option;
  6106. (*
  6107. Also about the Class<> type, should we crate all classes eagerly?
  6108. If false, it means that we should have a way at runtime to create the class when needed by
  6109. Type.resolveClass/Enum
  6110. *)
  6111. mutable rcf_class_eager_creation : bool;
  6112. rcf_hash_fields : (int, string) Hashtbl.t;
  6113. rcf_hash_paths : (path * int, string) Hashtbl.t;
  6114. (*
  6115. main expr -> field expr -> field string -> possible hash int (if optimize) -> possible set expr -> should_throw_exceptions -> changed expression
  6116. Changes a get / set field to the runtime resolution function
  6117. *)
  6118. mutable rcf_on_getset_field : texpr->texpr->string->int32 option->texpr option->bool->texpr;
  6119. mutable rcf_on_call_field : texpr->texpr->string->int32 option->texpr list->texpr;
  6120. mutable rcf_handle_statics : bool;
  6121. }
  6122. let new_ctx gen ft object_iface optimize dynamic_getset_field dynamic_call_field hash_function lookup_function insert_function remove_function handle_statics =
  6123. {
  6124. rcf_gen = gen;
  6125. rcf_ft = ft;
  6126. rcf_optimize = optimize;
  6127. rcf_float_special_case = true;
  6128. rcf_object_iface = object_iface;
  6129. rcf_create_getsetinvoke_fields = true;
  6130. rcf_create_get_type = true;
  6131. rcf_handle_impl_dynamic = true;
  6132. rcf_create_dyn_ctor = true;
  6133. rcf_max_func_arity = 10;
  6134. rcf_hash_function = hash_function;
  6135. rcf_lookup_function = lookup_function;
  6136. rcf_insert_function = insert_function;
  6137. rcf_remove_function = remove_function;
  6138. rcf_class_cl = None;
  6139. rcf_class_eager_creation = false;
  6140. rcf_hash_fields = Hashtbl.create 100;
  6141. rcf_hash_paths = Hashtbl.create 100;
  6142. rcf_on_getset_field = dynamic_getset_field;
  6143. rcf_on_call_field = dynamic_call_field;
  6144. rcf_handle_statics = handle_statics;
  6145. }
  6146. (*
  6147. methods as a bool option is a little laziness of my part.
  6148. None means that methods are included with normal fields;
  6149. Some(true) means collect only methods
  6150. Some(false) means collect only fields (and MethDynamic fields)
  6151. *)
  6152. let collect_fields cl (methods : bool option) (statics : bool option) =
  6153. let collected = Hashtbl.create 0 in
  6154. let collect cf acc =
  6155. if Meta.has Meta.CompilerGenerated cf.cf_meta || Meta.has Meta.SkipReflection cf.cf_meta then
  6156. acc
  6157. else match methods, cf.cf_kind with
  6158. | None, _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc
  6159. | Some true, Method MethDynamic -> acc
  6160. | Some true, Method _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc
  6161. | Some false, Method MethDynamic
  6162. | Some false, Var _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc
  6163. | _ -> acc
  6164. in
  6165. let collect_cfs cfs acc =
  6166. let rec loop cfs acc =
  6167. match cfs with
  6168. | [] -> acc
  6169. | hd :: tl -> loop tl (collect hd acc)
  6170. in
  6171. loop cfs acc
  6172. in
  6173. let rec loop cl acc =
  6174. let acc = match statics with
  6175. | None -> collect_cfs cl.cl_ordered_fields (collect_cfs cl.cl_ordered_statics acc)
  6176. | Some true -> collect_cfs cl.cl_ordered_statics acc
  6177. | Some false -> collect_cfs cl.cl_ordered_fields acc
  6178. in
  6179. match cl.cl_super with
  6180. | None -> acc
  6181. | Some(cl,_) ->
  6182. if not (is_hxgen (TClassDecl cl)) then loop cl acc else acc
  6183. in
  6184. loop cl []
  6185. let hash f =
  6186. let h = ref 0 in
  6187. for i = 0 to String.length f - 1 do
  6188. h := !h * 223 + int_of_char (String.unsafe_get f i);
  6189. done;
  6190. if Sys.word_size = 64 then Int32.to_int (Int32.shift_right (Int32.shift_left (Int32.of_int !h) 1) 1) else !h
  6191. let hash_field ctx f pos =
  6192. let h = hash f in
  6193. (try
  6194. let f2 = Hashtbl.find ctx.rcf_hash_paths (ctx.rcf_gen.gcurrent_path, h) in
  6195. if f <> f2 then ctx.rcf_gen.gcon.error ("Field conflict between " ^ f ^ " and " ^ f2) pos
  6196. with Not_found ->
  6197. Hashtbl.add ctx.rcf_hash_paths (ctx.rcf_gen.gcurrent_path, h) f;
  6198. Hashtbl.replace ctx.rcf_hash_fields h f);
  6199. h
  6200. (* ( tf_args, switch_var ) *)
  6201. let field_type_args ctx pos =
  6202. match ctx.rcf_optimize with
  6203. | true ->
  6204. let field_name, field_hash = alloc_var "field" ctx.rcf_gen.gcon.basic.tstring, alloc_var "hash" ctx.rcf_gen.gcon.basic.tint in
  6205. [field_name, None; field_hash, None], field_hash
  6206. | false ->
  6207. let field_name = alloc_var "field" ctx.rcf_gen.gcon.basic.tstring in
  6208. [field_name, None], field_name
  6209. let hash_field_i32 ctx pos field_name =
  6210. let i = hash_field ctx field_name pos in
  6211. let i = Int32.of_int (i) in
  6212. if i < Int32.zero then
  6213. Int32.logor (Int32.logand i (Int32.of_int 0x3FFFFFFF)) (Int32.shift_left Int32.one 30)
  6214. else i
  6215. let switch_case ctx pos field_name =
  6216. match ctx.rcf_optimize with
  6217. | true ->
  6218. let i = hash_field_i32 ctx pos field_name in
  6219. { eexpr = TConst(TInt(i)); etype = ctx.rcf_gen.gcon.basic.tint; epos = pos }
  6220. | false ->
  6221. { eexpr = TConst(TString(field_name)); etype = ctx.rcf_gen.gcon.basic.tstring; epos = pos }
  6222. (*
  6223. Will implement getField / setField which will follow the following rule:
  6224. function getField(field, isStatic, throwErrors, isCheck, handleProperty, isFirst):Dynamic
  6225. {
  6226. if (isStatic)
  6227. {
  6228. switch(field)
  6229. {
  6230. case "aStaticField": return ThisClass.aStaticField;
  6231. case "aDynamicField": return ThisClass.aDynamicField;
  6232. default:
  6233. if (isFirst) return getField_d(field, isStatic, throwErrors, handleProperty, false);
  6234. if(throwErrors) throw "Field not found"; else if (isCheck) return __undefined__ else return null;
  6235. }
  6236. } else {
  6237. switch(field)
  6238. {
  6239. case "aNormalField": return this.aNormalField;
  6240. case "aBoolField": return this.aBoolField;
  6241. case "aDoubleField": return this.aDoubleField;
  6242. default: return getField_d(field, isStatic, throwErrors, isCheck);
  6243. }
  6244. }
  6245. }
  6246. function getField_d(field, isStatic, throwErrors, handleProperty, isFirst):Float
  6247. {
  6248. if (isStatic)
  6249. {
  6250. switch(field)
  6251. {
  6252. case "aDynamicField": return cast ThisClass.aDynamicField;
  6253. default: if (throwErrors) throw "Field not found"; else return null;
  6254. }
  6255. }
  6256. etc...
  6257. }
  6258. function setField(field, value, isStatic):Dynamic {}
  6259. function setField_d(field, value:Float, isStatic):Float {}
  6260. *)
  6261. let call_super ctx fn_args ret_t cf cl this_t pos =
  6262. {
  6263. eexpr = TCall({
  6264. eexpr = TField({ eexpr = TConst(TSuper); etype = this_t; epos = pos }, FInstance(cl,List.map snd cl.cl_params,cf));
  6265. etype = TFun(fun_args fn_args, ret_t);
  6266. epos = pos;
  6267. }, List.map (fun (v,_) -> mk_local v pos) fn_args);
  6268. etype = ret_t;
  6269. epos = pos;
  6270. }
  6271. let mk_string ctx str pos =
  6272. { eexpr = TConst(TString(str)); etype = ctx.rcf_gen.gcon.basic.tstring; epos = pos }
  6273. let mk_int ctx i pos =
  6274. { eexpr = TConst(TInt(Int32.of_int i)); etype = ctx.rcf_gen.gcon.basic.tint; epos = pos }
  6275. let mk_bool ctx b pos =
  6276. { eexpr = TConst(TBool(b)); etype = ctx.rcf_gen.gcon.basic.tbool; epos = pos }
  6277. let mk_throw ctx str pos = { eexpr = TThrow (mk_string ctx str pos); etype = ctx.rcf_gen.gcon.basic.tvoid; epos = pos }
  6278. let enumerate_dynamic_fields ctx cl when_found =
  6279. let gen = ctx.rcf_gen in
  6280. let basic = gen.gcon.basic in
  6281. let pos = cl.cl_pos in
  6282. let vtmp = alloc_var "i" basic.tint in
  6283. let mk_for arr len =
  6284. let t = if ctx.rcf_optimize then basic.tint else basic.tstring in
  6285. let convert_str e = if ctx.rcf_optimize then ctx.rcf_lookup_function e else e in
  6286. let tmpinc = { eexpr = TUnop(Ast.Increment, Ast.Postfix, mk_local vtmp pos); etype = basic.tint; epos = pos } in
  6287. {
  6288. eexpr = TBlock [
  6289. { eexpr = TBinop(OpAssign, mk_local vtmp pos, mk_int ctx 0 pos); etype = basic.tint; epos = pos };
  6290. {
  6291. eexpr = TWhile (
  6292. { eexpr = TBinop(Ast.OpLt, mk_local vtmp pos, len); etype = basic.tbool; epos = pos },
  6293. mk_block (when_found (convert_str { eexpr = TArray (arr, tmpinc); etype = t; epos = pos })),
  6294. Ast.NormalWhile
  6295. );
  6296. etype = basic.tvoid;
  6297. epos = pos
  6298. }
  6299. ];
  6300. etype = basic.tvoid;
  6301. epos = pos;
  6302. }
  6303. in
  6304. let this_t = TInst(cl, List.map snd cl.cl_params) in
  6305. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  6306. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  6307. { eexpr = TVar (vtmp,None); etype = basic.tvoid; epos = pos }
  6308. ::
  6309. if ctx.rcf_optimize then
  6310. [
  6311. mk_for (mk_this (gen.gmk_internal_name "hx" "hashes") (gen.gclasses.nativearray basic.tint)) (mk_this (gen.gmk_internal_name "hx" "length") basic.tint);
  6312. mk_for (mk_this (gen.gmk_internal_name "hx" "hashes_f") (gen.gclasses.nativearray basic.tint)) (mk_this (gen.gmk_internal_name "hx" "length_f") basic.tint);
  6313. ] else [
  6314. mk_for (mk_this (gen.gmk_internal_name "hx" "hashes") (gen.gclasses.nativearray basic.tstring)) (mk_this (gen.gmk_internal_name "hx" "length") basic.tint);
  6315. mk_for (mk_this (gen.gmk_internal_name "hx" "hashes_f") (gen.gclasses.nativearray basic.tstring)) (mk_this (gen.gmk_internal_name "hx" "length_f") basic.tint);
  6316. ]
  6317. (* *********************
  6318. Dynamic lookup
  6319. *********************
  6320. This is the behavior of standard <implements Dynamic> classes. It will replace the error throwing
  6321. if a field doesn't exists when looking it up.
  6322. In order for it to work, an implementation for hash_function must be created.
  6323. hash_function is the function to be called/inlined that will allow us to lookup the hash into a sorted array of hashes.
  6324. A binary search or linear search algorithm may be implemented. The only need is that if not found, the NegBits of
  6325. the place where it should be inserted must be returned.
  6326. *)
  6327. let abstract_dyn_lookup_implementation ctx this hash_local may_value is_float pos =
  6328. let gen = ctx.rcf_gen in
  6329. let basic = gen.gcon.basic in
  6330. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  6331. let a_t = if ctx.rcf_optimize then basic.tint else basic.tstring in
  6332. let hx_hashes = mk_this (gen.gmk_internal_name "hx" "hashes") (gen.gclasses.nativearray a_t) in
  6333. let hx_hashes_f = mk_this (gen.gmk_internal_name "hx" "hashes_f") (gen.gclasses.nativearray a_t) in
  6334. let hx_dynamics = mk_this (gen.gmk_internal_name "hx" "dynamics") (gen.gclasses.nativearray t_empty) in
  6335. let hx_dynamics_f = mk_this (gen.gmk_internal_name "hx" "dynamics_f") (gen.gclasses.nativearray basic.tfloat) in
  6336. let hx_length = mk_this (gen.gmk_internal_name "hx" "length") (basic.tint) in
  6337. let hx_length_f = mk_this (gen.gmk_internal_name "hx" "length_f") (basic.tint) in
  6338. let res = alloc_var "res" basic.tint in
  6339. let fst_hash, snd_hash, fst_dynamics, snd_dynamics, fst_length, snd_length =
  6340. if is_float then
  6341. hx_hashes_f, hx_hashes, hx_dynamics_f, hx_dynamics, hx_length_f, hx_length
  6342. else
  6343. hx_hashes, hx_hashes_f, hx_dynamics, hx_dynamics_f, hx_length, hx_length_f
  6344. in
  6345. let res_local = mk_local res pos in
  6346. let gte = {
  6347. eexpr = TBinop(Ast.OpGte, res_local, { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos });
  6348. etype = basic.tbool;
  6349. epos = pos;
  6350. } in
  6351. let mk_tarray arr idx =
  6352. {
  6353. eexpr = TArray(arr, idx);
  6354. etype = gen.gclasses.nativearray_type arr.etype;
  6355. epos = pos;
  6356. }
  6357. in
  6358. let ret_t = if is_float then basic.tfloat else t_dynamic in
  6359. match may_value with
  6360. | None ->
  6361. (*
  6362. var res = lookup(this.__hx_hashes/f, hash);
  6363. if (res < 0)
  6364. {
  6365. res = lookup(this.__hx_hashes_f/_, hash);
  6366. if(res < 0)
  6367. return null;
  6368. else
  6369. return __hx_dynamics_f[res];
  6370. } else {
  6371. return __hx_dynamics[res];
  6372. }
  6373. *)
  6374. let block =
  6375. [
  6376. { eexpr = TVar(res, Some(ctx.rcf_hash_function hash_local fst_hash fst_length)); etype = basic.tvoid; epos = pos };
  6377. { eexpr = TIf(gte, mk_return (mk_tarray fst_dynamics res_local), Some({
  6378. eexpr = TBlock(
  6379. [
  6380. { eexpr = TBinop(Ast.OpAssign, res_local, ctx.rcf_hash_function hash_local snd_hash snd_length); etype = basic.tint; epos = pos };
  6381. { eexpr = TIf(gte, mk_return (mk_tarray snd_dynamics res_local), None); etype = ret_t; epos = pos }
  6382. ]);
  6383. etype = ret_t;
  6384. epos = pos;
  6385. })); etype = ret_t; epos = pos }
  6386. ] in
  6387. block
  6388. | Some value_local ->
  6389. (*
  6390. //if is not float:
  6391. //if (isNumber(value_local)) return this.__hx_setField_f(field, getNumber(value_local), false(not static));
  6392. var res = lookup(this.__hx_hashes/f, hash);
  6393. if (res >= 0)
  6394. {
  6395. return __hx_dynamics/f[res] = value_local;
  6396. } else {
  6397. res = lookup(this.__hx_hashes_f/_, hash);
  6398. if (res >= 0)
  6399. {
  6400. __hx_dynamics_f/_.splice(res,1);
  6401. __hx_hashes_f/_.splice(res,1);
  6402. }
  6403. }
  6404. __hx_hashses/_f.insert(~res, hash);
  6405. __hx_dynamics/_f.insert(~res, value_local);
  6406. return value_local;
  6407. *)
  6408. let neg_res = { eexpr = TUnop(Ast.NegBits, Ast.Prefix, res_local); etype = basic.tint; epos = pos } in
  6409. let res2 = alloc_var "res2" basic.tint in
  6410. let res2_local = mk_local res2 pos in
  6411. let gte2 = {
  6412. eexpr = TBinop(Ast.OpGte, res2_local, { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos });
  6413. etype = basic.tbool;
  6414. epos = pos;
  6415. } in
  6416. let block =
  6417. [
  6418. { eexpr = TVar(res, Some(ctx.rcf_hash_function hash_local fst_hash fst_length)); etype = basic.tvoid; epos = pos };
  6419. {
  6420. eexpr = TIf(gte,
  6421. mk_return { eexpr = TBinop(Ast.OpAssign, mk_tarray fst_dynamics res_local, value_local); etype = value_local.etype; epos = pos },
  6422. Some({ eexpr = TBlock([
  6423. { eexpr = TVar( res2, Some(ctx.rcf_hash_function hash_local snd_hash snd_length)); etype = basic.tvoid; epos = pos };
  6424. {
  6425. eexpr = TIf(gte2, { eexpr = TBlock([
  6426. ctx.rcf_remove_function snd_hash snd_length res2_local;
  6427. ctx.rcf_remove_function snd_dynamics snd_length res2_local;
  6428. mk (TUnop(Decrement,Postfix,snd_length)) basic.tint pos
  6429. ]); etype = t_dynamic; epos = pos }, None);
  6430. etype = t_dynamic;
  6431. epos = pos;
  6432. }
  6433. ]); etype = t_dynamic; epos = pos }));
  6434. etype = t_dynamic;
  6435. epos = pos;
  6436. };
  6437. ctx.rcf_insert_function fst_hash fst_length neg_res hash_local;
  6438. ctx.rcf_insert_function fst_dynamics fst_length neg_res value_local;
  6439. mk (TUnop(Increment,Postfix,fst_length)) basic.tint pos;
  6440. mk_return value_local
  6441. ] in
  6442. block
  6443. let get_delete_field ctx cl is_dynamic =
  6444. let pos = cl.cl_pos in
  6445. let this_t = TInst(cl, List.map snd cl.cl_params) in
  6446. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  6447. let gen = ctx.rcf_gen in
  6448. let basic = gen.gcon.basic in
  6449. let tf_args, switch_var = field_type_args ctx pos in
  6450. let local_switch_var = mk_local switch_var pos in
  6451. let fun_type = TFun(fun_args tf_args,basic.tbool) in
  6452. let cf = mk_class_field (gen.gmk_internal_name "hx" "deleteField") fun_type false pos (Method MethNormal) [] in
  6453. let body = if is_dynamic then begin
  6454. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  6455. let a_t = if ctx.rcf_optimize then basic.tint else basic.tstring in
  6456. let hx_hashes = mk_this (gen.gmk_internal_name "hx" "hashes") (gen.gclasses.nativearray a_t) in
  6457. let hx_hashes_f = mk_this (gen.gmk_internal_name "hx" "hashes_f") (gen.gclasses.nativearray a_t) in
  6458. let hx_dynamics = mk_this (gen.gmk_internal_name "hx" "dynamics") (gen.gclasses.nativearray t_empty) in
  6459. let hx_dynamics_f = mk_this (gen.gmk_internal_name "hx" "dynamics_f") (gen.gclasses.nativearray basic.tfloat) in
  6460. let hx_length = mk_this (gen.gmk_internal_name "hx" "length") (basic.tint) in
  6461. let hx_length_f = mk_this (gen.gmk_internal_name "hx" "length_f") (basic.tint) in
  6462. let res = alloc_var "res" basic.tint in
  6463. let res_local = mk_local res pos in
  6464. let gte = {
  6465. eexpr = TBinop(Ast.OpGte, res_local, { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos });
  6466. etype = basic.tbool;
  6467. epos = pos;
  6468. } in
  6469. (*
  6470. var res = lookup(this.__hx_hashes, hash);
  6471. if (res >= 0)
  6472. {
  6473. __hx_dynamics.splice(res,1);
  6474. __hx_hashes.splice(res,1);
  6475. return true;
  6476. } else {
  6477. res = lookup(this.__hx_hashes_f, hash);
  6478. if (res >= 0)
  6479. {
  6480. __hx_dynamics_f.splice(res,1);
  6481. __hx_hashes_f.splice(res,1);
  6482. return true;
  6483. }
  6484. }
  6485. return false;
  6486. *)
  6487. [
  6488. { eexpr = TVar(res,Some(ctx.rcf_hash_function local_switch_var hx_hashes hx_length)); etype = basic.tvoid; epos = pos };
  6489. {
  6490. eexpr = TIf(gte, { eexpr = TBlock([
  6491. ctx.rcf_remove_function hx_hashes hx_length res_local;
  6492. ctx.rcf_remove_function hx_dynamics hx_length res_local;
  6493. mk (TUnop(Decrement,Postfix,hx_length)) basic.tint pos;
  6494. mk_return { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos }
  6495. ]); etype = t_dynamic; epos = pos }, Some({ eexpr = TBlock([
  6496. { eexpr = TBinop(Ast.OpAssign, res_local, ctx.rcf_hash_function local_switch_var hx_hashes_f hx_length_f); etype = basic.tint; epos = pos };
  6497. { eexpr = TIf(gte, { eexpr = TBlock([
  6498. ctx.rcf_remove_function hx_hashes_f hx_length_f res_local;
  6499. ctx.rcf_remove_function hx_dynamics_f hx_length_f res_local;
  6500. mk (TUnop(Decrement,Postfix,hx_length_f)) basic.tint pos;
  6501. mk_return { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos }
  6502. ]); etype = t_dynamic; epos = pos }, None); etype = t_dynamic; epos = pos }
  6503. ]); etype = t_dynamic; epos = pos }));
  6504. etype = t_dynamic;
  6505. epos = pos;
  6506. };
  6507. mk_return { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }
  6508. ]
  6509. end else
  6510. [
  6511. mk_return { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }
  6512. ] in
  6513. (* create function *)
  6514. let fn =
  6515. {
  6516. tf_args = tf_args;
  6517. tf_type = basic.tbool;
  6518. tf_expr = { eexpr = TBlock(body); etype = t_dynamic; epos = pos }
  6519. } in
  6520. cf.cf_expr <- Some({ eexpr = TFunction(fn); etype = fun_type; epos = pos });
  6521. cf
  6522. let rec is_first_dynamic cl =
  6523. match cl.cl_super with
  6524. | Some(cl,_) ->
  6525. if is_some cl.cl_dynamic then false else is_first_dynamic cl
  6526. | None -> true
  6527. let is_override cl = match cl.cl_super with
  6528. | Some (cl, _) when is_hxgen (TClassDecl cl) -> true
  6529. | _ -> false
  6530. let get_args t = match follow t with
  6531. | TFun(args,ret) -> args,ret
  6532. | _ -> assert false
  6533. (* WARNING: this will only work if overloading contructors is possible on target language *)
  6534. let implement_dynamic_object_ctor ctx cl =
  6535. let rec is_side_effects_free e =
  6536. match e.eexpr with
  6537. | TConst _
  6538. | TLocal _
  6539. | TFunction _
  6540. | TTypeExpr _ ->
  6541. true
  6542. | TNew(clnew,[],params) when clnew == cl ->
  6543. List.for_all is_side_effects_free params
  6544. | TUnop(Increment,_,_)
  6545. | TUnop(Decrement,_,_)
  6546. | TBinop(OpAssign,_,_)
  6547. | TBinop(OpAssignOp _,_,_) ->
  6548. false
  6549. | TUnop(_,_,e) ->
  6550. is_side_effects_free e
  6551. | TArray(e1,e2)
  6552. | TBinop(_,e1,e2) ->
  6553. is_side_effects_free e1 && is_side_effects_free e2
  6554. | TIf(cond,e1,Some e2) ->
  6555. is_side_effects_free cond && is_side_effects_free e1 && is_side_effects_free e2
  6556. | TField(e,_)
  6557. | TParenthesis e | TMeta(_,e) -> is_side_effects_free e
  6558. | TArrayDecl el -> List.for_all is_side_effects_free el
  6559. | TCast(e,_) -> is_side_effects_free e
  6560. | _ -> false
  6561. in
  6562. let pos = cl.cl_pos in
  6563. let gen = ctx.rcf_gen in
  6564. let basic = gen.gcon.basic in
  6565. let hasht = if ctx.rcf_optimize then basic.tint else basic.tstring in
  6566. let hashes_field = gen.gmk_internal_name "hx" "hashes", gen.gclasses.nativearray hasht in
  6567. let hashes_f_field = gen.gmk_internal_name "hx" "hashes_f", gen.gclasses.nativearray hasht in
  6568. let dynamics_field = gen.gmk_internal_name "hx" "dynamics", gen.gclasses.nativearray t_empty in
  6569. let dynamics_f_field = gen.gmk_internal_name "hx" "dynamics_f", gen.gclasses.nativearray basic.tfloat in
  6570. let fields =
  6571. [
  6572. hashes_field;
  6573. dynamics_field;
  6574. hashes_f_field;
  6575. dynamics_f_field;
  6576. ] in
  6577. let hashes_var = alloc_var (fst hashes_field) (snd hashes_field) in
  6578. let hashes_f_var = alloc_var (fst hashes_f_field) (snd hashes_f_field) in
  6579. let tf_args = [
  6580. hashes_var, None;
  6581. alloc_var (fst dynamics_field) (snd dynamics_field), None;
  6582. hashes_f_var, None;
  6583. alloc_var (fst dynamics_f_field) (snd dynamics_f_field), None;
  6584. ] in
  6585. let this = { eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_params); epos = pos } in
  6586. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  6587. let fun_t = TFun(fun_args tf_args,basic.tvoid) in
  6588. let ctor = mk_class_field "new" fun_t true pos (Method MethNormal) [] in
  6589. ctor.cf_expr <- Some(
  6590. {
  6591. eexpr = TFunction({
  6592. tf_args = tf_args;
  6593. tf_type = basic.tvoid;
  6594. tf_expr =
  6595. {
  6596. eexpr = TBlock(
  6597. List.map (fun (v,_) ->
  6598. { eexpr = TBinop(Ast.OpAssign, mk_this v.v_name v.v_type, mk_local v pos); etype = v.v_type; epos = pos }
  6599. ) tf_args
  6600. @
  6601. [
  6602. mk (TBinop(OpAssign, mk_this (gen.gmk_internal_name "hx" "length") basic.tint, gen.gclasses.nativearray_len (mk_local hashes_var pos) pos)) basic.tint pos;
  6603. mk (TBinop(OpAssign, mk_this (gen.gmk_internal_name "hx" "length_f") basic.tint, gen.gclasses.nativearray_len (mk_local hashes_f_var pos) pos)) basic.tint pos;
  6604. ]
  6605. );
  6606. etype = basic.tvoid;
  6607. epos = pos
  6608. }
  6609. });
  6610. etype = fun_t;
  6611. epos = pos
  6612. });
  6613. add_constructor cl ctor;
  6614. (* default ctor also *)
  6615. let ctor = mk_class_field "new" (TFun([],basic.tvoid)) false pos (Method MethNormal) [] in
  6616. ctor.cf_expr <- Some {
  6617. eexpr = TFunction {
  6618. tf_type = basic.tvoid;
  6619. tf_args = [];
  6620. tf_expr = {
  6621. eexpr = TBlock(List.map (fun (f,t) ->
  6622. { eexpr = TBinop(Ast.OpAssign, mk_this f t,{ eexpr = TCall(mk_local v_nativearray pos, []); etype = t; epos = pos; }); etype = t; epos = pos }
  6623. ) fields);
  6624. etype = basic.tvoid;
  6625. epos = pos;
  6626. }
  6627. };
  6628. etype = ctor.cf_type;
  6629. epos = pos;
  6630. };
  6631. add_constructor cl ctor;
  6632. (* and finally we will return a function that transforms a TObjectDecl into a new DynamicObject() call *)
  6633. let rec loop objdecl acc acc_f =
  6634. match objdecl with
  6635. | [] -> acc,acc_f
  6636. | (name,expr) :: tl ->
  6637. let real_t = gen.greal_type expr.etype in
  6638. match follow expr.etype with
  6639. | TInst ( { cl_path = ["haxe"], "Int64" }, [] ) ->
  6640. loop tl ((name, gen.ghandle_cast t_dynamic real_t expr) :: acc) acc_f
  6641. | _ ->
  6642. if like_float real_t && not (like_i64 real_t) then
  6643. loop tl acc ((name, gen.ghandle_cast basic.tfloat real_t expr) :: acc_f)
  6644. else
  6645. loop tl ((name, gen.ghandle_cast t_dynamic real_t expr) :: acc) acc_f
  6646. in
  6647. let may_hash_field s =
  6648. if ctx.rcf_optimize then begin
  6649. (* let hash_field ctx f pos = *)
  6650. { eexpr = TConst(TInt (hash_field_i32 ctx pos s)); etype = basic.tint; epos = pos }
  6651. end else begin
  6652. { eexpr = TConst(TString s); etype = basic.tstring; epos = pos }
  6653. end
  6654. in
  6655. let do_objdecl e objdecl =
  6656. let exprs_before = ref [] in
  6657. let rec change_exprs decl acc = match decl with
  6658. | (name,expr) :: tl ->
  6659. if is_side_effects_free expr then
  6660. change_exprs tl ((name,expr) :: acc)
  6661. else begin
  6662. let var = mk_temp gen "odecl" expr.etype in
  6663. exprs_before := { eexpr = TVar(var,Some expr); etype = basic.tvoid; epos = expr.epos } :: !exprs_before;
  6664. change_exprs tl ((name,mk_local var expr.epos) :: acc)
  6665. end
  6666. | [] -> acc
  6667. in
  6668. let objdecl = change_exprs objdecl [] in
  6669. let odecl, odecl_f = loop objdecl [] [] in
  6670. let changed_expr = List.map (fun (s,e) -> (may_hash_field s,e)) in
  6671. let odecl, odecl_f = changed_expr odecl, changed_expr odecl_f in
  6672. let sort_fn (e1,_) (e2,_) =
  6673. match e1.eexpr, e2.eexpr with
  6674. | TConst(TInt i1), TConst(TInt i2) -> compare i1 i2
  6675. | TConst(TString s1), TConst(TString s2) -> compare s1 s2
  6676. | _ -> assert false
  6677. in
  6678. let odecl, odecl_f = List.sort sort_fn odecl, List.sort sort_fn odecl_f in
  6679. let ret = {
  6680. e with eexpr = TNew(cl,[],
  6681. [
  6682. mk_nativearray_decl gen hasht (List.map fst odecl) pos;
  6683. mk_nativearray_decl gen t_empty (List.map snd odecl) pos;
  6684. mk_nativearray_decl gen hasht (List.map fst odecl_f) pos;
  6685. mk_nativearray_decl gen basic.tfloat (List.map snd odecl_f) pos;
  6686. ]);
  6687. } in
  6688. match !exprs_before with
  6689. | [] -> ret
  6690. | block ->
  6691. {
  6692. eexpr = TBlock(List.rev block @ [ret]);
  6693. etype = ret.etype;
  6694. epos = ret.epos;
  6695. }
  6696. in
  6697. do_objdecl
  6698. let implement_dynamics ctx cl =
  6699. let pos = cl.cl_pos in
  6700. let is_override = is_override cl in
  6701. if is_some cl.cl_dynamic then begin
  6702. if is_first_dynamic cl then begin
  6703. (*
  6704. * add hx_hashes, hx_hashes_f, hx_dynamics, hx_dynamics_f to class
  6705. * implement hx_deleteField
  6706. *)
  6707. let gen = ctx.rcf_gen in
  6708. let basic = gen.gcon.basic in
  6709. let hasht = if ctx.rcf_optimize then basic.tint else basic.tstring in
  6710. let new_fields =
  6711. [
  6712. mk_class_field (gen.gmk_internal_name "hx" "hashes") (gen.gclasses.nativearray hasht) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6713. mk_class_field (gen.gmk_internal_name "hx" "dynamics") (gen.gclasses.nativearray t_empty) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6714. mk_class_field (gen.gmk_internal_name "hx" "hashes_f") (gen.gclasses.nativearray hasht) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6715. mk_class_field (gen.gmk_internal_name "hx" "dynamics_f") (gen.gclasses.nativearray basic.tfloat) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6716. ] in
  6717. (if cl.cl_path <> (["haxe"; "lang"], "DynamicObject") then
  6718. List.iter (fun cf -> cf.cf_expr <- Some { eexpr = TCall(mk_local v_nativearray pos, []); etype = cf.cf_type; epos = cf.cf_pos }) new_fields
  6719. );
  6720. let delete = get_delete_field ctx cl true in
  6721. let new_fields = new_fields @ [
  6722. mk_class_field (gen.gmk_internal_name "hx" "length") (basic.tint) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6723. mk_class_field (gen.gmk_internal_name "hx" "length_f") (basic.tint) false pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
  6724. delete;
  6725. ] in
  6726. List.iter (fun cf ->
  6727. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields
  6728. ) new_fields;
  6729. (*
  6730. let rec last_ctor cl =
  6731. match cl.cl_constructor with
  6732. | None -> (match cl.cl_super with | None -> None | Some (cl,_) -> last_ctor cl)
  6733. | Some c -> Some c
  6734. in
  6735. *)
  6736. (*
  6737. in order for the next to work, we need to execute our script before InitFunction, so the expressions inside the variables are initialized by the constructor
  6738. *)
  6739. (*
  6740. Now we need to add their initialization.
  6741. This will consist of different parts:
  6742. Check if there are constructors. If not, create one and add initialization to it (calling super, ok)
  6743. If there are, add as first statement (or second if there is a super() call in the first)
  6744. If class has @:dynamicObject meta, also create another new() class with its parameters as constructor arguments
  6745. *)
  6746. cl.cl_ordered_fields <- cl.cl_ordered_fields @ new_fields;
  6747. if is_override then cl.cl_overrides <- delete :: cl.cl_overrides
  6748. end
  6749. end else if not is_override then begin
  6750. let delete = get_delete_field ctx cl false in
  6751. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [delete];
  6752. cl.cl_fields <- PMap.add delete.cf_name delete cl.cl_fields
  6753. end
  6754. let implement_create_empty ctx cl =
  6755. let gen = ctx.rcf_gen in
  6756. let basic = gen.gcon.basic in
  6757. let pos = cl.cl_pos in
  6758. let is_override = is_override cl in
  6759. let tparams = List.map (fun _ -> t_empty) cl.cl_params in
  6760. let create =
  6761. let arr = alloc_var "arr" (basic.tarray t_dynamic) in
  6762. let tf_args = [ arr, None ] in
  6763. let t = TFun(fun_args tf_args, t_dynamic) in
  6764. let cf = mk_class_field (gen.gmk_internal_name "hx" "create") t false pos (Method MethNormal) [] in
  6765. let i = ref 0 in
  6766. let arr_local = mk_local arr pos in
  6767. let ctor = if is_some cl.cl_constructor then cl.cl_constructor else get_last_ctor cl in
  6768. let params = match ctor with
  6769. | None -> []
  6770. | Some ctor ->
  6771. List.map (fun (n,_,t) ->
  6772. let old = !i in
  6773. incr i;
  6774. {
  6775. eexpr = TArray(arr_local, { eexpr = TConst(TInt (Int32.of_int old)); etype = basic.tint; epos = pos } );
  6776. etype = t_dynamic;
  6777. epos = pos
  6778. }
  6779. ) ( fst ( get_fun ctor.cf_type ) )
  6780. in
  6781. let expr = mk_return {
  6782. eexpr = TNew(cl, tparams, params);
  6783. etype = TInst(cl, tparams);
  6784. epos = pos
  6785. } in
  6786. let fn = {
  6787. eexpr = TFunction({
  6788. tf_args = tf_args;
  6789. tf_type = t_dynamic;
  6790. tf_expr = mk_block expr
  6791. });
  6792. etype = t;
  6793. epos = pos
  6794. } in
  6795. cf.cf_expr <- Some fn;
  6796. cf
  6797. in
  6798. let create_empty =
  6799. let t = TFun([],t_dynamic) in
  6800. let cf = mk_class_field (gen.gmk_internal_name "hx" "createEmpty") t false pos (Method MethNormal) [] in
  6801. let fn = {
  6802. eexpr = TFunction({
  6803. tf_args = [];
  6804. tf_type = t_dynamic;
  6805. tf_expr = mk_block (mk_return ( gen.gtools.rf_create_empty cl tparams pos ))
  6806. });
  6807. etype = t;
  6808. epos = pos
  6809. } in
  6810. cf.cf_expr <- Some fn;
  6811. cf
  6812. in
  6813. (* if rcf_handle_statics is false, there is no reason to make createEmpty/create not be static *)
  6814. if ctx.rcf_handle_statics then begin
  6815. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [create_empty; create];
  6816. cl.cl_fields <- PMap.add create_empty.cf_name create_empty cl.cl_fields;
  6817. cl.cl_fields <- PMap.add create.cf_name create cl.cl_fields;
  6818. if is_override then begin
  6819. cl.cl_overrides <- create_empty :: create :: cl.cl_overrides
  6820. end
  6821. end else begin
  6822. cl.cl_ordered_statics <- cl.cl_ordered_statics @ [create_empty; create];
  6823. cl.cl_statics <- PMap.add create_empty.cf_name create_empty cl.cl_statics;
  6824. cl.cl_statics <- PMap.add create.cf_name create cl.cl_statics
  6825. end
  6826. (*
  6827. Implements:
  6828. __hx_lookupField(field:String, throwErrors:Bool, isCheck:Bool, handleProperties:Bool, isFirst:Bool):Dynamic
  6829. __hx_lookupField_f(field:String, throwErrors:Bool, handleProperties:Bool, isFirst:Bool):Float
  6830. __hx_lookupSetField(field:String, value:Dynamic, handleProperties:Bool, isFirst:Bool):Dynamic;
  6831. __hx_lookupSetField(field:String, value:Float, handleProperties:Bool, isFirst:Bool):Float;
  6832. *)
  6833. let implement_final_lookup ctx cl =
  6834. let gen = ctx.rcf_gen in
  6835. let basic = gen.gcon.basic in
  6836. let pos = cl.cl_pos in
  6837. let is_override = is_override cl in
  6838. let this = { eexpr = TConst(TThis); etype = TInst(cl, List.map snd cl.cl_params); epos = pos } in
  6839. (*
  6840. this function will create the class fields and call callback for each version
  6841. callback : is_float fields_args switch_var throw_errors_option is_check_option value_option : texpr list
  6842. *)
  6843. let create_cfs is_dynamic callback =
  6844. let create_cf is_float is_set =
  6845. let name = gen.gmk_internal_name "hx" ( (if is_set then "lookupSetField" else "lookupField") ^ (if is_float then "_f" else "") ) in
  6846. let field_args, switch_var = field_type_args ctx pos in
  6847. let ret_t = if is_float then basic.tfloat else t_dynamic in
  6848. let tf_args, throw_errors_opt =
  6849. if is_set then
  6850. field_args, None
  6851. else
  6852. let v = alloc_var "throwErrors" basic.tbool in
  6853. field_args @ [v,None], Some v
  6854. in
  6855. let tf_args, is_check_opt =
  6856. if is_set || is_float then
  6857. tf_args, None
  6858. else
  6859. let v = alloc_var "isCheck" basic.tbool in
  6860. tf_args @ [v,None], Some v
  6861. in
  6862. let tf_args, value_opt =
  6863. if not is_set then
  6864. tf_args, None
  6865. else
  6866. let v = alloc_var "value" ret_t in
  6867. field_args @ [v,None], Some v
  6868. in
  6869. let fun_t = TFun(fun_args tf_args, ret_t) in
  6870. let cf = mk_class_field name fun_t false pos (Method MethNormal) [] in
  6871. let block = callback is_float field_args switch_var throw_errors_opt is_check_opt value_opt in
  6872. let block = if not is_set then let tl = begin
  6873. let throw_errors_local = mk_local (get throw_errors_opt) pos in
  6874. let mk_check_throw msg =
  6875. {
  6876. eexpr = TIf(throw_errors_local, mk_throw ctx msg pos, Some (mk_return (null ret_t pos)));
  6877. etype = ret_t;
  6878. epos = pos
  6879. } in
  6880. let mk_may_check_throw msg = if is_dynamic then mk_return (null ret_t pos) else mk_check_throw msg in
  6881. if is_float then begin
  6882. [
  6883. mk_may_check_throw "Field not found or incompatible field type.";
  6884. ]
  6885. end else begin
  6886. let is_check_local = mk_local (get is_check_opt) pos in
  6887. [
  6888. {
  6889. eexpr = TIf(is_check_local, mk_return (undefined pos), Some( mk_may_check_throw "Field not found." ));
  6890. etype = ret_t;
  6891. epos = pos;
  6892. }
  6893. ]
  6894. end
  6895. end in block @ tl else block in
  6896. cf.cf_expr <- Some(
  6897. {
  6898. eexpr = TFunction({
  6899. tf_args = tf_args;
  6900. tf_type = ret_t;
  6901. tf_expr = { eexpr = TBlock(block); etype = ret_t; epos = pos }
  6902. });
  6903. etype = fun_t;
  6904. epos = pos
  6905. }
  6906. );
  6907. cf
  6908. in
  6909. let cfs =
  6910. [
  6911. create_cf false false;
  6912. create_cf true false;
  6913. create_cf false true;
  6914. create_cf true true
  6915. ] in
  6916. cl.cl_ordered_fields <- cl.cl_ordered_fields @ cfs;
  6917. List.iter (fun cf ->
  6918. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields;
  6919. if is_override then cl.cl_overrides <- cf :: cl.cl_overrides
  6920. ) cfs
  6921. in
  6922. if is_some cl.cl_dynamic then begin
  6923. (* let abstract_dyn_lookup_implementation ctx this hash_local may_value is_float pos = *)
  6924. (* callback : is_float fields_args switch_var throw_errors_option is_check_option value_option : texpr list *)
  6925. if is_first_dynamic cl then
  6926. create_cfs true (fun is_float fields_args switch_var _ _ value_opt ->
  6927. abstract_dyn_lookup_implementation ctx this (mk_local switch_var pos) (Option.map (fun v -> mk_local v pos) value_opt) is_float pos
  6928. )
  6929. end else if not is_override then begin
  6930. create_cfs false (fun is_float fields_args switch_var _ _ value_opt ->
  6931. match value_opt with
  6932. | None -> (* is not set *)
  6933. []
  6934. | Some _ -> (* is set *)
  6935. if is_float then
  6936. [ mk_throw ctx "Cannot access field for writing or incompatible type." pos ]
  6937. else
  6938. [ mk_throw ctx "Cannot access field for writing." pos ]
  6939. )
  6940. end
  6941. (* *)
  6942. let implement_get_set ctx cl =
  6943. let gen = ctx.rcf_gen in
  6944. let mk_cfield is_set is_float =
  6945. let pos = cl.cl_pos in
  6946. let basic = ctx.rcf_gen.gcon.basic in
  6947. let tf_args, switch_var = field_type_args ctx pos in
  6948. let field_args = tf_args in
  6949. let local_switch_var = { eexpr = TLocal(switch_var); etype = switch_var.v_type; epos = pos } in
  6950. let is_static = alloc_var "isStatic" basic.tbool in
  6951. let is_static_local = { eexpr = TLocal(is_static); etype = basic.tbool; epos = pos } in
  6952. let handle_prop = alloc_var "handleProperties" basic.tbool in
  6953. let handle_prop_local = mk_local handle_prop pos in
  6954. let this = { eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_params); epos = pos } in
  6955. let mk_this_call_raw name fun_t params =
  6956. { eexpr = TCall( { (mk_field_access gen this name pos) with etype = fun_t; }, params ); etype = snd (get_args fun_t); epos = pos }
  6957. in
  6958. let tf_args = if ctx.rcf_handle_statics then tf_args @ [is_static, None] else tf_args in
  6959. let fun_type = ref (TFun([], basic.tvoid)) in
  6960. let fun_name = ctx.rcf_gen.gmk_internal_name "hx" ( (if is_set then "setField" else "getField") ^ (if is_float then "_f" else "") ) in
  6961. let cfield = mk_class_field fun_name !fun_type false pos (Method MethNormal) [] in
  6962. let maybe_cast e = e in
  6963. let t = TInst(cl, List.map snd cl.cl_params) in
  6964. (* if it's not latest hxgen class -> check super *)
  6965. let mk_do_default args do_default =
  6966. match cl.cl_super with
  6967. | None -> fun () -> maybe_cast (do_default ())
  6968. | Some (super, sparams) when not (is_hxgen (TClassDecl super)) ->
  6969. fun () -> maybe_cast (do_default ())
  6970. | _ ->
  6971. fun () ->
  6972. mk_return {
  6973. eexpr = TCall(
  6974. { eexpr = TField({ eexpr = TConst TSuper; etype = t; epos = pos }, FInstance(cl, List.map snd cl.cl_params, cfield)); etype = !fun_type; epos = pos },
  6975. (List.map (fun (v,_) -> mk_local v pos) args) );
  6976. etype = if is_float then basic.tfloat else t_dynamic;
  6977. epos = pos;
  6978. };
  6979. in
  6980. (* if it is set function, there are some different set fields to do *)
  6981. let do_default, do_default_static , do_field, tf_args = if is_set then begin
  6982. let value_var = alloc_var "value" (if is_float then basic.tfloat else t_dynamic) in
  6983. let value_local = { eexpr = TLocal(value_var); etype = value_var.v_type; epos = pos } in
  6984. let tf_args = tf_args @ [value_var,None; handle_prop, None; ] in
  6985. let lookup_name = gen.gmk_internal_name "hx" ("lookupSetField" ^ if is_float then "_f" else "") in
  6986. let do_default =
  6987. fun () ->
  6988. mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [value_var,None]),value_var.v_type)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ value_local ] ))
  6989. in
  6990. let do_field cf cf_type is_static =
  6991. let get_field ethis = { eexpr = TField (ethis, if is_static then FStatic (cl, cf) else FInstance(cl, List.map snd cl.cl_params, cf)); etype = cf_type; epos = pos } in
  6992. let this = if is_static then mk_classtype_access cl pos else { eexpr = TConst(TThis); etype = t; epos = pos } in
  6993. let value_local = if is_float then match follow cf_type with
  6994. | TInst({ cl_kind = KTypeParameter _ }, _) ->
  6995. mk_cast t_dynamic value_local
  6996. | _ ->
  6997. value_local
  6998. else
  6999. value_local
  7000. in
  7001. let ret =
  7002. {
  7003. eexpr = TBlock([
  7004. {
  7005. eexpr = TBinop(Ast.OpAssign,
  7006. get_field this,
  7007. mk_cast cf_type value_local);
  7008. etype = cf_type;
  7009. epos = pos;
  7010. };
  7011. mk_return value_local
  7012. ]);
  7013. etype = cf_type;
  7014. epos = pos;
  7015. } in
  7016. match cf.cf_kind with
  7017. | Var { v_write = AccCall } ->
  7018. let bl =
  7019. [
  7020. mk_this_call_raw ("set_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ value_local ];
  7021. mk_return value_local
  7022. ] in
  7023. if Type.is_extern_field cf then
  7024. { eexpr = TBlock bl; etype = value_local.etype; epos = pos }
  7025. else
  7026. {
  7027. eexpr = TIf(
  7028. handle_prop_local,
  7029. { eexpr = TBlock bl; etype = value_local.etype; epos = pos },
  7030. Some ret);
  7031. etype = value_local.etype;
  7032. epos = pos;
  7033. }
  7034. | _ ->
  7035. ret
  7036. in
  7037. (mk_do_default tf_args do_default, do_default, do_field, tf_args)
  7038. end else begin
  7039. (* (field, isStatic, throwErrors, isCheck):Dynamic *)
  7040. let throw_errors = alloc_var "throwErrors" basic.tbool in
  7041. let throw_errors_local = mk_local throw_errors pos in
  7042. let do_default, tf_args = if not is_float then begin
  7043. let is_check = alloc_var "isCheck" basic.tbool in
  7044. let is_check_local = mk_local is_check pos in
  7045. let tf_args = tf_args @ [ throw_errors,None; ] in
  7046. (* default: if (isCheck) return __undefined__ else if(throwErrors) throw "Field not found"; else return null; *)
  7047. let lookup_name = gen.gmk_internal_name "hx" "lookupField" in
  7048. let do_default =
  7049. fun () ->
  7050. mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [throw_errors,None;is_check,None; ]),t_dynamic)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ throw_errors_local; is_check_local; ] ))
  7051. in
  7052. (do_default, tf_args @ [ is_check,None; handle_prop,None; ])
  7053. end else begin
  7054. let tf_args = tf_args @ [ throw_errors,None; ] in
  7055. let lookup_name = gen.gmk_internal_name "hx" "lookupField_f" in
  7056. let do_default =
  7057. fun () ->
  7058. mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [throw_errors,None; ]),basic.tfloat)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ throw_errors_local; ] ))
  7059. in
  7060. (do_default, tf_args @ [ handle_prop,None; ])
  7061. end in
  7062. let get_field cf cf_type ethis cl name =
  7063. match cf.cf_kind with
  7064. | Var { v_read = AccCall } when Type.is_extern_field cf ->
  7065. mk_return (mk_this_call_raw ("get_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ ])
  7066. | Var { v_read = AccCall } ->
  7067. {
  7068. eexpr = TIf(
  7069. handle_prop_local,
  7070. mk_return (mk_this_call_raw ("get_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ ]),
  7071. Some { eexpr = TField (ethis, FInstance(cl, List.map snd cl.cl_params, cf)); etype = cf_type; epos = pos }
  7072. );
  7073. etype = cf_type;
  7074. epos = pos;
  7075. }
  7076. | Var _
  7077. | Method MethDynamic -> { eexpr = TField (ethis, FInstance(cl,List.map snd cl.cl_params,cf)); etype = cf_type; epos = pos }
  7078. | _ ->
  7079. { eexpr = TField (this, FClosure(Some (cl,[]), cf)); etype = cf_type; epos = pos } (* TODO: FClosure change *)
  7080. in
  7081. let do_field cf cf_type static =
  7082. let this = if static then mk_classtype_access cl pos else { eexpr = TConst(TThis); etype = t; epos = pos } in
  7083. match is_float, follow cf_type with
  7084. | true, TInst( { cl_kind = KTypeParameter _ }, _ ) ->
  7085. mk_return (mk_cast basic.tfloat (mk_cast t_dynamic (get_field cf cf_type this cl cf.cf_name)))
  7086. | _ ->
  7087. mk_return (maybe_cast (get_field cf cf_type this cl cf.cf_name ))
  7088. in
  7089. (mk_do_default tf_args do_default, do_default, do_field, tf_args)
  7090. end in
  7091. let get_fields static =
  7092. let ret = collect_fields cl ( if is_float || is_set then Some (false) else None ) (Some static) in
  7093. let ret = if is_set then List.filter (fun (_,cf) ->
  7094. match cf.cf_kind with
  7095. (* | Var { v_write = AccNever } -> false *)
  7096. | _ -> not (Meta.has Meta.ReadOnly cf.cf_meta)) ret
  7097. else
  7098. List.filter (fun (_,cf) ->
  7099. match cf.cf_kind with
  7100. (* | Var { v_read = AccNever } -> false *)
  7101. | _ -> true) ret in
  7102. if is_float then
  7103. List.filter (fun (_,cf) -> (* TODO: maybe really apply_params in cf.cf_type. The benefits would be limited, though *)
  7104. match follow (ctx.rcf_gen.greal_type (ctx.rcf_gen.gfollow#run_f cf.cf_type)) with
  7105. | TDynamic _ | TMono _
  7106. | TInst ({ cl_kind = KTypeParameter _ }, _) -> true
  7107. | t when like_float t && not (like_i64 t) -> true
  7108. | _ -> false
  7109. ) ret
  7110. else
  7111. (* dynamic will always contain all references *)
  7112. ret
  7113. in
  7114. (* now we have do_default, do_field and tf_args *)
  7115. (* so create the switch expr *)
  7116. fun_type := TFun(List.map (fun (v,_) -> (v.v_name, false, v.v_type)) tf_args, if is_float then basic.tfloat else t_dynamic );
  7117. let has_fields = ref false in
  7118. let mk_switch static =
  7119. let fields = get_fields static in
  7120. let fields = List.filter (fun (_, cf) -> match is_set, cf.cf_kind with
  7121. | true, Var { v_write = AccCall } -> true
  7122. | false, Var { v_read = AccCall } -> true
  7123. | _ -> not (Type.is_extern_field cf)) fields
  7124. in
  7125. (if fields <> [] then has_fields := true);
  7126. let cases = List.map (fun (names, cf) ->
  7127. (if names = [] then assert false);
  7128. (List.map (switch_case ctx pos) names, do_field cf cf.cf_type static)
  7129. ) fields in
  7130. let default = Some(if static then do_default_static() else do_default()) in
  7131. { eexpr = TSwitch(local_switch_var, cases, default); etype = basic.tvoid; epos = pos }
  7132. in
  7133. let content = if ctx.rcf_handle_statics then
  7134. mk_block { eexpr = TIf(is_static_local, mk_switch true, Some(mk_switch false)); etype = basic.tvoid; epos = pos }
  7135. else
  7136. mk_block (mk_switch false)
  7137. in
  7138. let is_override = match cl.cl_super with
  7139. | Some (cl, _) when is_hxgen (TClassDecl cl) -> true
  7140. | _ -> false
  7141. in
  7142. if !has_fields || (not is_override) then begin
  7143. let func =
  7144. {
  7145. tf_args = tf_args;
  7146. tf_type = if is_float then basic.tfloat else t_dynamic;
  7147. tf_expr = content;
  7148. } in
  7149. let func = { eexpr = TFunction(func); etype = !fun_type; epos = pos } in
  7150. cfield.cf_type <- !fun_type;
  7151. cfield.cf_expr <- Some func;
  7152. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cfield];
  7153. cl.cl_fields <- PMap.add fun_name cfield cl.cl_fields;
  7154. (if is_override then cl.cl_overrides <- cfield :: cl.cl_overrides)
  7155. end else ()
  7156. in
  7157. (if ctx.rcf_float_special_case then mk_cfield true true);
  7158. mk_cfield true false;
  7159. mk_cfield false false;
  7160. (if ctx.rcf_float_special_case then mk_cfield false true)
  7161. let mk_field_access_r ctx pos local field is_float is_static throw_errors set_option =
  7162. let is_set = is_some set_option in
  7163. let gen = ctx.rcf_gen in
  7164. let basic = gen.gcon.basic in
  7165. let fun_name = ctx.rcf_gen.gmk_internal_name "hx" ( (if is_set then "setField" else "getField") ^ (if is_float then "_f" else "") ) in
  7166. let tf_args, _ = field_type_args ctx pos in
  7167. let tf_args, args = fun_args tf_args, field in
  7168. let rett = if is_float then basic.tfloat else t_dynamic in
  7169. let tf_args, args = if ctx.rcf_handle_statics then tf_args @ [ "isStatic", false, basic.tbool ], args @ [is_static] else tf_args, args in
  7170. let tf_args, args = if is_set then tf_args @ [ "setVal", false, rett ], args @ [get set_option] else tf_args, args in
  7171. let tf_args, args = tf_args @ [ "throwErrors",false,basic.tbool ], args @ [throw_errors] in
  7172. let tf_args, args = if is_set || is_float then tf_args, args else tf_args @ [ "isCheck", false, basic.tbool ], args @ [{ eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }] in
  7173. let tf_args, args = tf_args @ [ "handleProperties",false,basic.tbool; ], args @ [ mk_bool ctx false pos; ] in
  7174. {
  7175. eexpr = TCall(
  7176. { (mk_field_access gen local fun_name pos) with etype = TFun(tf_args, rett) },
  7177. args);
  7178. etype = rett;
  7179. epos = pos;
  7180. }
  7181. let implement_fields ctx cl =
  7182. (*
  7183. implement two kinds of fields get:
  7184. classFields
  7185. generic 'fields': receives a parameter isInstance
  7186. will receive an Array<String> and start pushing the fields into it.
  7187. //add all common fields
  7188. if(isInstance)
  7189. {
  7190. //add methods
  7191. } else {
  7192. super.fields(isInstance, array);
  7193. }
  7194. *)
  7195. let gen = ctx.rcf_gen in
  7196. let basic = gen.gcon.basic in
  7197. let pos = cl.cl_pos in
  7198. (*
  7199. let rec has_no_dynamic cl =
  7200. if is_some cl.cl_dynamic then
  7201. false
  7202. else match cl.cl_super with
  7203. | None -> true
  7204. | Some(cl,_) -> has_no_dynamic cl
  7205. in
  7206. *)
  7207. (* Type.getClassFields() *)
  7208. if ctx.rcf_handle_statics then begin
  7209. let name = gen.gmk_internal_name "hx" "classFields" in
  7210. let v_base_arr = alloc_var "baseArr" (basic.tarray basic.tstring) in
  7211. let base_arr = mk_local v_base_arr pos in
  7212. let tf_args = [v_base_arr,None] in
  7213. let t = TFun(fun_args tf_args, basic.tvoid) in
  7214. let cf = mk_class_field name t false pos (Method MethNormal) [] in
  7215. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cf];
  7216. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields;
  7217. (if is_override cl then cl.cl_overrides <- cf :: cl.cl_overrides);
  7218. (*
  7219. var newarr = ["field1", "field2"] ...;
  7220. *)
  7221. let fields = collect_fields cl None (Some true) in
  7222. let mk_push value =
  7223. { eexpr = TCall({ (mk_field_access gen base_arr "push" pos) with etype = TFun(["x", false, basic.tstring], basic.tint) }, [value] ); etype = basic.tint; epos = pos }
  7224. in
  7225. let new_arr_contents =
  7226. {
  7227. eexpr = TBlock(
  7228. List.map (fun (_,cf) -> mk_push { eexpr = TConst(TString(cf.cf_name)); etype = basic.tstring; epos = pos }) fields
  7229. );
  7230. etype = basic.tvoid;
  7231. epos = pos
  7232. } in
  7233. let expr = new_arr_contents in
  7234. let fn =
  7235. {
  7236. tf_args = tf_args;
  7237. tf_type = basic.tvoid;
  7238. tf_expr = mk_block expr
  7239. } in
  7240. cf.cf_expr <- Some { eexpr = TFunction(fn); etype = t; epos = pos }
  7241. end;
  7242. let fields =
  7243. (*
  7244. function __hx_fields(baseArr:Array<String>, isInstanceFields:Bool)
  7245. {
  7246. //add all variable fields
  7247. //then:
  7248. if (isInstanceFields)
  7249. {
  7250. //add all method fields as well
  7251. } else {
  7252. super.__hx_fields(baseArr, isInstanceFields);
  7253. }
  7254. }
  7255. *)
  7256. let name = gen.gmk_internal_name "hx" "getFields" in
  7257. let v_base_arr, v_is_inst = alloc_var "baseArr" (basic.tarray basic.tstring), alloc_var "isInstanceFields" basic.tbool in
  7258. let base_arr, is_inst = mk_local v_base_arr pos, mk_local v_is_inst pos in
  7259. let tf_args = (v_base_arr,None) :: (if ctx.rcf_handle_statics then [v_is_inst, None] else []) in
  7260. let t = TFun(fun_args tf_args, basic.tvoid) in
  7261. let cf = mk_class_field name t false pos (Method MethNormal) [] in
  7262. let mk_push value =
  7263. { eexpr = TCall({ (mk_field_access gen base_arr "push" pos) with etype = TFun(["x", false, basic.tstring], basic.tint); }, [value] ); etype = basic.tint; epos = pos }
  7264. in
  7265. let has_value = ref false in
  7266. let map_fields =
  7267. List.map (fun (_,cf) ->
  7268. match cf.cf_kind with
  7269. | Var _
  7270. | Method MethDynamic when not (List.memq cf cl.cl_overrides) ->
  7271. has_value := true;
  7272. mk_push { eexpr = TConst(TString(cf.cf_name)); etype = basic.tstring; epos = pos }
  7273. | _ -> null basic.tvoid pos
  7274. )
  7275. in
  7276. (*
  7277. if it is first_dynamic, then we need to enumerate the dynamic fields
  7278. *)
  7279. let if_not_inst = if is_some cl.cl_dynamic && is_first_dynamic cl then begin
  7280. has_value := true;
  7281. Some (enumerate_dynamic_fields ctx cl mk_push)
  7282. end else
  7283. None
  7284. in
  7285. let if_not_inst = if is_override cl then
  7286. Some(
  7287. {
  7288. eexpr = TBlock(
  7289. (if is_some if_not_inst then get if_not_inst else []) @
  7290. [{
  7291. eexpr = TCall(
  7292. { eexpr = TField({ eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_params); epos = pos }, FInstance(cl, List.map snd cl.cl_params, cf)); etype = t; epos = pos },
  7293. base_arr :: (if ctx.rcf_handle_statics then [is_inst] else [])
  7294. );
  7295. etype = basic.tvoid;
  7296. epos = pos
  7297. }]
  7298. );
  7299. etype = basic.tvoid;
  7300. epos = pos
  7301. }
  7302. ) else if is_some if_not_inst then
  7303. Some({ eexpr = TBlock(get if_not_inst); etype = basic.tvoid; epos = pos })
  7304. else
  7305. None
  7306. in
  7307. let expr_contents = map_fields (collect_fields cl (Some false) (Some false)) in
  7308. let expr_contents = if ctx.rcf_handle_statics then
  7309. expr_contents @
  7310. [ {
  7311. eexpr = TIf(is_inst,
  7312. { eexpr = TBlock( map_fields (collect_fields cl (Some true) (Some false)) ); etype = basic.tvoid; epos = pos },
  7313. if_not_inst
  7314. );
  7315. etype = basic.tvoid;
  7316. epos = pos
  7317. } ]
  7318. else
  7319. expr_contents @ (if is_some if_not_inst then [ get if_not_inst ] else [])
  7320. in
  7321. let expr =
  7322. {
  7323. eexpr = TBlock( expr_contents );
  7324. etype = basic.tvoid;
  7325. epos = pos;
  7326. } in
  7327. let fn =
  7328. {
  7329. tf_args = tf_args;
  7330. tf_type = basic.tvoid;
  7331. tf_expr = expr
  7332. } in
  7333. (if !has_value || (not (is_override cl)) then begin
  7334. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cf];
  7335. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields;
  7336. (if is_override cl then cl.cl_overrides <- cf :: cl.cl_overrides)
  7337. end);
  7338. cf.cf_expr <- Some { eexpr = TFunction(fn); etype = t; epos = pos }
  7339. in
  7340. ignore fields
  7341. let implement_class_methods ctx cl =
  7342. ctx.rcf_class_cl <- Some cl;
  7343. let pos = cl.cl_pos in
  7344. let gen = ctx.rcf_gen in
  7345. let basic = gen.gcon.basic in
  7346. (*
  7347. fields -> redirected to classFields
  7348. getField -> redirected to getField with isStatic true
  7349. setField -> isStatic true
  7350. invokeField -> isStatic true
  7351. getClass -> null
  7352. create -> proxy
  7353. createEmpty -> proxy
  7354. *)
  7355. let is_override = is_override cl in
  7356. let name = "classProxy" in
  7357. let t = (TInst(ctx.rcf_object_iface,[])) in
  7358. (* let cf = mk_class_field name t false pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in *)
  7359. let register_cf cf override =
  7360. cl.cl_ordered_fields <- cf :: cl.cl_ordered_fields;
  7361. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields;
  7362. if override then cl.cl_overrides <- cf :: cl.cl_overrides
  7363. in
  7364. (* register_cf cf false; *)
  7365. let this_t = TInst(cl, List.map snd cl.cl_params) in
  7366. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  7367. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  7368. let proxy = mk_this name t in
  7369. (*let ctor =
  7370. let cls = alloc_var "cls" t in
  7371. let tf_args = [cls, None] in
  7372. let t = TFun(fun_args tf_args, basic.tvoid) in
  7373. let cf = mk_class_field "new" t true pos (Method MethNormal) [] in
  7374. cf.cf_expr <- Some({
  7375. eexpr = TFunction({
  7376. tf_args = tf_args;
  7377. tf_type = basic.tvoid;
  7378. tf_expr = mk_block {
  7379. eexpr = TBinop(Ast.OpAssign, proxy, mk_local cls pos);
  7380. etype = cls.v_type;
  7381. epos = pos;
  7382. }
  7383. });
  7384. etype = t;
  7385. epos = pos;
  7386. });
  7387. cf
  7388. in
  7389. register_cf ctor false;*)
  7390. (* setting it as DynamicObject makes getClass return null *)
  7391. let get_class =
  7392. cl.cl_meta <- (Meta.DynamicObject, [], pos) :: cl.cl_meta
  7393. in
  7394. ignore get_class;
  7395. (* fields -> if isInstanceField, redir the method. If not, return classFields *)
  7396. let fields =
  7397. let name = gen.gmk_internal_name "hx" "getFields" in
  7398. let v_base_arr, v_is_inst = alloc_var "baseArr" (basic.tarray basic.tstring), alloc_var "isInstanceFields" basic.tbool in
  7399. let base_arr, is_inst = mk_local v_base_arr pos, mk_local v_is_inst pos in
  7400. let tf_args = [ v_base_arr,None; v_is_inst, None ] in
  7401. let t = TFun(fun_args tf_args, basic.tvoid) in
  7402. let cf = mk_class_field name t false pos (Method MethNormal) [] in
  7403. cf.cf_expr <- Some({
  7404. eexpr = TFunction({
  7405. tf_args = tf_args;
  7406. tf_type = basic.tvoid;
  7407. tf_expr = mk_block {
  7408. eexpr = TIf(is_inst,
  7409. { eexpr = TCall( { (mk_field_access gen proxy name pos) with etype = t }, [base_arr;is_inst]); etype = basic.tvoid; epos = pos },
  7410. Some { eexpr = TCall(mk_this (gen.gmk_internal_name "hx" "classFields") (TFun(["baseArr",false,basic.tarray basic.tstring], basic.tvoid)), [base_arr]); etype = basic.tvoid; epos = pos });
  7411. etype = basic.tvoid;
  7412. epos = pos
  7413. }
  7414. });
  7415. etype = t;
  7416. epos = pos;
  7417. });
  7418. cf
  7419. in
  7420. register_cf fields (is_override);
  7421. let do_proxy field tf_args ret is_static_argnum =
  7422. let field = gen.gmk_internal_name "hx" field in
  7423. let t = TFun(fun_args tf_args, ret) in
  7424. let cf = mk_class_field field t false pos (Method MethNormal) [] in
  7425. let is_void = is_void ret in
  7426. let may_return e = if is_void then mk_block e else mk_block (mk_return e) in
  7427. let i = ref 0 in
  7428. cf.cf_expr <- Some({
  7429. eexpr = TFunction({
  7430. tf_args = tf_args;
  7431. tf_type = ret;
  7432. tf_expr = may_return {
  7433. eexpr = TCall(
  7434. { (mk_field_access gen proxy field pos) with etype = t },
  7435. List.map (fun (v,_) ->
  7436. let lasti = !i in
  7437. incr i;
  7438. if lasti = is_static_argnum then
  7439. { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos }
  7440. else
  7441. mk_local v pos
  7442. ) tf_args);
  7443. etype = ret;
  7444. epos = pos
  7445. }
  7446. });
  7447. etype = t;
  7448. epos = pos;
  7449. });
  7450. cf
  7451. in
  7452. (* getClassFields -> redir *)
  7453. register_cf (do_proxy "classFields" [ alloc_var "baseArr" (basic.tarray basic.tstring), None ] basic.tvoid (-1)) true;
  7454. (*register_cf (do_proxy "classFields" [ alloc_var "baseArr" (basic.tarray basic.tstring), None ] basic.tvoid (-1)) true;*)
  7455. let fst_args, _ = field_type_args ctx pos in
  7456. let fst_args_len = List.length fst_args in
  7457. (* getField -> redir the method with static = true *)
  7458. (* setField -> redir the methods with static = true *)
  7459. (if ctx.rcf_float_special_case then
  7460. register_cf (do_proxy "getField_f" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "throwErrors" basic.tbool, None ]) basic.tfloat fst_args_len) true;
  7461. register_cf (do_proxy "setField_f" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "value" basic.tfloat, None ]) basic.tfloat fst_args_len) true
  7462. );
  7463. register_cf (do_proxy "getField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "throwErrors" basic.tbool, None; alloc_var "isCheck" basic.tbool, None; alloc_var "handleProperties" basic.tbool,None; ]) t_dynamic fst_args_len) true;
  7464. register_cf (do_proxy "setField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "value" t_dynamic, None; alloc_var "handleProperties" basic.tbool,None; ]) t_dynamic fst_args_len) true;
  7465. (* invokeField -> redir the method with static = true *)
  7466. register_cf (do_proxy "invokeField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "dynArgs" (basic.tarray t_dynamic), None ]) t_dynamic fst_args_len) true;
  7467. (* create / createEmpty -> redir the method *)
  7468. register_cf (do_proxy "create" [ alloc_var "arr" (basic.tarray t_dynamic), None ] t_dynamic (-1)) true;
  7469. register_cf (do_proxy "createEmpty" [ ] t_dynamic (-1)) true
  7470. let implement_get_class ctx cl =
  7471. (*
  7472. if it is DynamicObject, return null;
  7473. if it is not, just do the following:
  7474. if (typehandle(this.class) == typehandle(MyClass))
  7475. return (MyClass.__hx_class != null ? MyClass.__hx_class : MyClass.__hx_class = create_empty(MyClass));
  7476. return MyClass.__hx_class = haxe.lang.Runtime.getClass(MyClass);
  7477. implement both on static and non-static contexts. This way we can call without references.
  7478. *)
  7479. let gen = ctx.rcf_gen in
  7480. let basic = gen.gcon.basic in
  7481. let pos = cl.cl_pos in
  7482. let tclass = get_cl ( (Hashtbl.find gen.gtypes ([],"Class")) ) in
  7483. let cls = TInst(tclass, [ TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_params) ]) in
  7484. let cls_dyn = TInst(tclass, [t_dynamic]) in
  7485. let expr, static_cfs =
  7486. if Meta.has Meta.DynamicObject cl.cl_meta then
  7487. mk_return (null t_dynamic pos), []
  7488. else
  7489. let cache_name = (gen.gmk_internal_name "hx" "class") in
  7490. let cache = mk_class_field cache_name cls false pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in
  7491. cl.cl_ordered_statics <- cl.cl_ordered_statics @ [ cache ];
  7492. cl.cl_statics <- PMap.add cache_name cache cl.cl_statics;
  7493. let cache_access = mk_static_field_access cl cache_name cls pos in
  7494. let create_expr = {
  7495. eexpr = TNew(get ctx.rcf_class_cl, [], [gen.gtools.rf_create_empty cl (List.map (fun _ -> t_dynamic) cl.cl_params) pos]);
  7496. etype = cls;
  7497. epos = pos
  7498. } in
  7499. (if ctx.rcf_class_eager_creation then cache.cf_expr <- Some(create_expr));
  7500. let expr = if ctx.rcf_class_eager_creation then
  7501. mk_return cache_access
  7502. else
  7503. mk_return {
  7504. eexpr = TIf(
  7505. { eexpr = TBinop(Ast.OpNotEq, cache_access, null cls pos); etype = basic.tbool; epos = pos },
  7506. cache_access,
  7507. Some({ eexpr = TBinop(Ast.OpAssign, cache_access, create_expr); etype = cls; epos = pos })
  7508. );
  7509. etype = cls;
  7510. epos = pos
  7511. }
  7512. in
  7513. expr, []
  7514. in
  7515. let func =
  7516. {
  7517. eexpr = TFunction({
  7518. tf_args = [];
  7519. tf_type = cls_dyn;
  7520. tf_expr = expr
  7521. });
  7522. etype = TFun([],cls_dyn);
  7523. epos = pos
  7524. } in
  7525. let get_cl_static = mk_class_field (gen.gmk_internal_name "hx" "getClassStatic") (TFun([],cls_dyn)) false pos (Method MethNormal) [] in
  7526. let get_cl = mk_class_field (gen.gmk_internal_name "hx" "getClass") (TFun([],cls_dyn)) false pos (Method MethNormal) [] in
  7527. get_cl_static.cf_expr <- Some func;
  7528. get_cl.cf_expr <- Some func;
  7529. let all_f = [get_cl] in
  7530. cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_f;
  7531. List.iter (fun cf -> cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields) all_f;
  7532. let all_f = get_cl_static :: static_cfs in
  7533. cl.cl_ordered_statics <- cl.cl_ordered_statics @ all_f;
  7534. List.iter (fun cf -> cl.cl_statics <- PMap.add cf.cf_name cf cl.cl_statics) all_f;
  7535. if is_override cl then cl.cl_overrides <- get_cl :: cl.cl_overrides
  7536. let implement_invokeField ctx ~slow_invoke cl =
  7537. (*
  7538. There are two ways to implement an haxe reflection-enabled class:
  7539. When we extend a non-hxgen class, and when we extend the base HxObject class.
  7540. Because of the added boiler plate we'd add every time we extend a non-hxgen class to implement a big IHxObject
  7541. interface, we'll handle the cases differently when implementing each interface.
  7542. At the IHxObject interface, there's only invokeDynamic(field, args[]), while at the HxObject class there are
  7543. the other, more optimized methods, that follow the Function class interface.
  7544. Since this will only be called by the Closure class, this conversion can be properly dealt with later.
  7545. TODO: create the faster version. By now only invokeDynamic will be implemented
  7546. *)
  7547. let gen = ctx.rcf_gen in
  7548. let basic = gen.gcon.basic in
  7549. let pos = cl.cl_pos in
  7550. let has_method = ref false in
  7551. let is_override = ref false in
  7552. let rec extends_hxobject cl =
  7553. match cl.cl_super with
  7554. | None -> true
  7555. | Some (cl,_) when is_hxgen (TClassDecl cl) -> is_override := true; extends_hxobject cl
  7556. | _ -> false
  7557. in
  7558. let field_args, switch_var = field_type_args ctx cl.cl_pos in
  7559. let field_args_exprs = List.map (fun (v,_) -> mk_local v pos) field_args in
  7560. let is_static = alloc_var "isStatic" basic.tbool in
  7561. let dynamic_arg = alloc_var "dynargs" (basic.tarray t_dynamic) in
  7562. let all_args = field_args @ (if ctx.rcf_handle_statics then [ is_static,None; dynamic_arg,None ] else [ dynamic_arg, None ] ) in
  7563. let fun_t = TFun(fun_args all_args, t_dynamic) in
  7564. let this_t = TInst(cl, List.map snd cl.cl_params) in
  7565. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  7566. let apply_object cf = apply_params cf.cf_params (List.map (fun _ -> t_dynamic) cf.cf_params) cf.cf_type in
  7567. let mk_this_call_raw name fun_t params =
  7568. { eexpr = TCall( { (mk_field_access gen this name pos) with etype = fun_t }, params ); etype = snd (get_args fun_t); epos = pos }
  7569. in
  7570. let mk_this_call cf params =
  7571. let t = apply_object cf in
  7572. (* the return type transformation into Dynamic *)
  7573. (* is meant to avoid return-type casting after functions with *)
  7574. (* type parameters are properly inferred at TypeParams.infer_params *)
  7575. (* e.g. function getArray<T : SomeType>(t:T):Array<T>; after infer_params, *)
  7576. (* T will be inferred as SomeType, but the returned type will still be typed *)
  7577. (* as Array<Dynamic> *)
  7578. let args, ret = get_args t in
  7579. let ret = match follow ret with
  7580. | TAbstract ({ a_path = ([], "Void") },[]) -> ret
  7581. | _ -> ret
  7582. in
  7583. mk_this_call_raw cf.cf_name (TFun(args, ret)) params
  7584. in
  7585. let mk_static_call cf params =
  7586. let t = apply_object cf in
  7587. let _, ret = get_fun (follow t) in
  7588. { eexpr = TCall( mk_static_field_access cl cf.cf_name t pos, params ); etype = ret; epos = pos }
  7589. in
  7590. let extends_hxobject = extends_hxobject cl in
  7591. ignore extends_hxobject;
  7592. (* creates a dynamicInvoke of the class fields listed here *)
  7593. (*
  7594. function dynamicInvoke(field, isStatic, dynargs)
  7595. {
  7596. switch(field)
  7597. {
  7598. case "a": this.a(dynargs[0], dynargs[1], dynargs[2]...);
  7599. default: super.dynamicInvoke //or this.getField(field).invokeField(dynargs)
  7600. }
  7601. }
  7602. *)
  7603. let dyn_fun = mk_class_field (ctx.rcf_gen.gmk_internal_name "hx" "invokeField") fun_t false cl.cl_pos (Method MethNormal) [] in
  7604. let mk_switch_dyn cfs static old =
  7605. (* mk_class_field name t public pos kind params = *)
  7606. let get_case (names,cf) =
  7607. has_method := true;
  7608. let i = ref 0 in
  7609. let dyn_arg_local = mk_local dynamic_arg pos in
  7610. let cases = List.map (switch_case ctx pos) names in
  7611. (cases,
  7612. { eexpr = TReturn(Some ( (if static then mk_static_call else mk_this_call) cf (List.map (fun (name,_,t) ->
  7613. let ret = { eexpr = TArray(dyn_arg_local, mk_int ctx !i pos); etype = t_dynamic; epos = pos } in
  7614. incr i;
  7615. ret
  7616. ) (fst (get_args (cf.cf_type))) ) ));
  7617. etype = basic.tvoid;
  7618. epos = pos
  7619. }
  7620. )
  7621. in
  7622. let cfs = List.filter (fun (_,cf) -> match cf.cf_kind with
  7623. | Method _ -> if List.memq cf cl.cl_overrides then false else true
  7624. | _ -> true) cfs
  7625. in
  7626. let cases = List.map get_case cfs in
  7627. let cases = match old with
  7628. | [] -> cases
  7629. | _ ->
  7630. let ncases = List.map (fun cf -> switch_case ctx pos cf.cf_name) old in
  7631. ( ncases, mk_return ((get slow_invoke) this (mk_local (fst (List.hd field_args)) pos) (mk_local dynamic_arg pos)) ) :: cases
  7632. in
  7633. let default = if !is_override && not(static) then
  7634. (* let call_super ctx fn_args ret_t fn_name this_t pos = *)
  7635. { eexpr = TReturn(Some (call_super ctx all_args t_dynamic dyn_fun cl this_t pos) ); etype = basic.tvoid; epos = pos }
  7636. (*else if ctx.rcf_create_getsetinvoke_fields then (* we always need to run create_getset before *)
  7637. let get_field_name = gen.gmk_internal_name "hx" "getField" in
  7638. { eexpr = TReturn( Some (mk_this_call (PMap.find get_field_name cl.cl_fields) [mk_local dynamic_arg pos] ) ); etype = basic.tvoid; epos = pos }*)
  7639. else (
  7640. (*let field = (gen.gtools.r_field false (TInst(ctx.rcf_ft.func_class,[])) this (mk_local (fst (List.hd all_args)) pos)) in*)
  7641. (* let mk_field_access ctx pos local field is_float is_static throw_errors set_option = *)
  7642. let field = mk_field_access_r ctx pos this field_args_exprs false {eexpr = TConst(TBool static); etype = basic.tbool; epos = pos} { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos } None in
  7643. let field = mk_cast (TInst(ctx.rcf_ft.func_class,[])) field in
  7644. mk_return {
  7645. eexpr = TCall(
  7646. mk_field_access gen field (gen.gmk_internal_name "hx" "invokeDynamic") pos,
  7647. [mk_local dynamic_arg pos]);
  7648. etype = t_dynamic;
  7649. epos = pos
  7650. } )
  7651. in
  7652. {
  7653. eexpr = TSwitch(mk_local switch_var pos, cases, Some default);
  7654. etype = basic.tvoid;
  7655. epos = pos;
  7656. }
  7657. in
  7658. let contents =
  7659. let statics = collect_fields cl (Some true) (Some true) in
  7660. let nonstatics = collect_fields cl (Some true) (Some false) in
  7661. let old_nonstatics = ref [] in
  7662. let nonstatics = match slow_invoke with
  7663. | None -> nonstatics
  7664. | Some _ ->
  7665. List.filter (fun (n,cf) ->
  7666. let is_old = not (PMap.mem cf.cf_name cl.cl_fields) || List.memq cf cl.cl_overrides in
  7667. (if is_old then old_nonstatics := cf :: !old_nonstatics);
  7668. not is_old
  7669. ) nonstatics
  7670. in
  7671. if ctx.rcf_handle_statics then
  7672. {
  7673. eexpr = TIf(mk_local is_static pos, mk_switch_dyn statics true [], Some(mk_switch_dyn nonstatics false !old_nonstatics));
  7674. etype = basic.tvoid;
  7675. epos = pos;
  7676. } else
  7677. mk_switch_dyn nonstatics false !old_nonstatics
  7678. in
  7679. dyn_fun.cf_expr <- Some
  7680. {
  7681. eexpr = TFunction(
  7682. {
  7683. tf_args = all_args;
  7684. tf_type = t_dynamic;
  7685. tf_expr = mk_block contents;
  7686. });
  7687. etype = TFun(fun_args all_args, t_dynamic);
  7688. epos = pos;
  7689. };
  7690. if !is_override && not (!has_method) then () else begin
  7691. cl.cl_ordered_fields <- cl.cl_ordered_fields @ [dyn_fun];
  7692. cl.cl_fields <- PMap.add dyn_fun.cf_name dyn_fun cl.cl_fields;
  7693. (if !is_override then cl.cl_overrides <- dyn_fun :: cl.cl_overrides)
  7694. end
  7695. let implement_varargs_cl ctx cl =
  7696. let pos = cl.cl_pos in
  7697. let gen = ctx.rcf_gen in
  7698. let basic = gen.gcon.basic in
  7699. let this_t = TInst(cl, List.map snd cl.cl_params) in
  7700. let this = { eexpr = TConst(TThis); etype = this_t ; epos = pos } in
  7701. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  7702. let invokedyn = gen.gmk_internal_name "hx" "invokeDynamic" in
  7703. let idyn_t = TFun([gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic], t_dynamic) in
  7704. let this_idyn = mk_this invokedyn idyn_t in
  7705. let map_fn arity ret vars api =
  7706. let rec loop i acc =
  7707. if i < 0 then
  7708. acc
  7709. else
  7710. let obj = api i t_dynamic None in
  7711. loop (i - 1) (obj :: acc)
  7712. in
  7713. let call_arg = if arity = (-1) then
  7714. api (-1) t_dynamic None
  7715. else if arity = 0 then
  7716. null (basic.tarray t_empty) pos
  7717. else
  7718. { eexpr = TArrayDecl(loop (arity - 1) []); etype = basic.tarray t_empty; epos = pos }
  7719. in
  7720. let expr = {
  7721. eexpr = TCall(
  7722. this_idyn,
  7723. [ call_arg ]
  7724. );
  7725. etype = t_dynamic;
  7726. epos = pos
  7727. } in
  7728. let expr = if like_float ret && not (like_int ret) then mk_cast ret expr else expr in
  7729. [], mk_return expr
  7730. in
  7731. let all_cfs = List.filter (fun cf -> cf.cf_name <> "new" && cf.cf_name <> (invokedyn) && match cf.cf_kind with Method _ -> true | _ -> false) (ctx.rcf_ft.map_base_classfields cl true map_fn) in
  7732. cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_cfs;
  7733. List.iter (fun cf ->
  7734. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields
  7735. ) all_cfs;
  7736. List.iter (fun cf ->
  7737. cl.cl_overrides <- cf :: cl.cl_overrides
  7738. ) cl.cl_ordered_fields
  7739. let implement_closure_cl ctx cl =
  7740. let pos = cl.cl_pos in
  7741. let gen = ctx.rcf_gen in
  7742. let basic = gen.gcon.basic in
  7743. let field_args, _ = field_type_args ctx pos in
  7744. let obj_arg = alloc_var "target" (TInst(ctx.rcf_object_iface, [])) in
  7745. let this_t = TInst(cl, List.map snd cl.cl_params) in
  7746. let this = { eexpr = TConst(TThis); etype = this_t ; epos = pos } in
  7747. let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
  7748. let tf_args = field_args @ [obj_arg, None] in
  7749. let cfs, ctor_body = List.fold_left (fun (acc_cf,acc_expr) (v,_) ->
  7750. let cf = mk_class_field v.v_name v.v_type false pos (Var { v_read = AccNormal; v_write = AccNormal } ) [] in
  7751. let expr = { eexpr = TBinop(Ast.OpAssign, mk_this v.v_name v.v_type, mk_local v pos); etype = v.v_type; epos = pos } in
  7752. (cf :: acc_cf, expr :: acc_expr)
  7753. ) ([], []) tf_args in
  7754. let map_fn arity ret vars api =
  7755. let this_obj = mk_this "target" (TInst(ctx.rcf_object_iface, [])) in
  7756. let rec loop i acc =
  7757. if i < 0 then
  7758. acc
  7759. else
  7760. let obj = api i t_dynamic None in
  7761. loop (i - 1) (obj :: acc)
  7762. in
  7763. let call_arg = if arity = (-1) then
  7764. api (-1) t_dynamic None
  7765. else if arity = 0 then
  7766. null (basic.tarray t_empty) pos
  7767. else
  7768. { eexpr = TArrayDecl(loop (arity - 1) []); etype = basic.tarray t_empty; epos = pos }
  7769. in
  7770. let expr = {
  7771. eexpr = TCall(
  7772. mk_field_access gen this_obj (gen.gmk_internal_name "hx" "invokeField") pos,
  7773. (List.map (fun (v,_) -> mk_this v.v_name v.v_type) field_args) @
  7774. (if ctx.rcf_handle_statics then
  7775. [ { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }; call_arg ]
  7776. else
  7777. [ call_arg ]
  7778. )
  7779. );
  7780. etype = t_dynamic;
  7781. epos = pos
  7782. } in
  7783. let expr = if like_float ret && not (like_int ret) then mk_cast ret expr else expr in
  7784. [], mk_return expr
  7785. in
  7786. let all_cfs = List.filter (fun cf -> cf.cf_name <> "new" && match cf.cf_kind with Method _ -> true | _ -> false) (ctx.rcf_ft.map_base_classfields cl true map_fn) in
  7787. List.iter (fun cf ->
  7788. cl.cl_overrides <- cf :: cl.cl_overrides
  7789. ) all_cfs;
  7790. let all_cfs = cfs @ all_cfs in
  7791. cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_cfs;
  7792. List.iter (fun cf ->
  7793. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields
  7794. ) all_cfs;
  7795. let ctor_t = TFun(fun_args tf_args, basic.tvoid) in
  7796. let ctor_cf = mk_class_field "new" ctor_t true pos (Method MethNormal) [] in
  7797. ctor_cf.cf_expr <- Some {
  7798. eexpr = TFunction({
  7799. tf_args = tf_args;
  7800. tf_type = basic.tvoid;
  7801. tf_expr = { eexpr = TBlock({
  7802. eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(cl,[]); epos = pos }, [mk_int ctx (-1) pos; mk_int ctx (-1) pos]);
  7803. etype = basic.tvoid;
  7804. epos = pos
  7805. } :: ctor_body); etype = basic.tvoid; epos = pos }
  7806. });
  7807. etype = ctor_t;
  7808. epos = pos
  7809. };
  7810. cl.cl_constructor <- Some ctor_cf;
  7811. let closure_fun eclosure e field is_static =
  7812. let f = { eexpr = TConst(TString field); etype = basic.tstring; epos = eclosure.epos } in
  7813. let args = if ctx.rcf_optimize then [ f; { eexpr = TConst(TInt (hash_field_i32 ctx eclosure.epos field)); etype = basic.tint; epos = eclosure.epos } ] else [ f ] in
  7814. let args = args @ [ mk_cast (TInst(ctx.rcf_object_iface, [])) e ] in
  7815. { eclosure with eexpr = TNew(cl,[],args) }
  7816. in
  7817. closure_fun
  7818. let get_closure_func ctx closure_cl =
  7819. let gen = ctx.rcf_gen in
  7820. let basic = gen.gcon.basic in
  7821. let closure_func eclosure e field is_static =
  7822. mk_cast eclosure.etype { eclosure with
  7823. eexpr = TNew(closure_cl, [], [
  7824. e;
  7825. { eexpr = TConst(TString field); etype = basic.tstring; epos = eclosure.epos }
  7826. ] @ (
  7827. if ctx.rcf_optimize then [ { eexpr = TConst(TInt (hash_field_i32 ctx eclosure.epos field)); etype = basic.tint; epos = eclosure.epos } ] else []
  7828. ));
  7829. etype = TInst(closure_cl,[])
  7830. }
  7831. in
  7832. closure_func
  7833. (*
  7834. main expr -> field expr -> field string -> possible set expr -> should_throw_exceptions -> changed expression
  7835. Changes a get / set
  7836. *
  7837. mutable rcf_on_getset_field : texpr->texpr->string->texpr option->bool->texpr;*)
  7838. let configure_dynamic_field_access ctx is_synf =
  7839. let gen = ctx.rcf_gen in
  7840. let is_dynamic expr fexpr field =
  7841. match (field_access_esp gen (gen.greal_type fexpr.etype) field) with
  7842. | FEnumField _
  7843. | FClassField _ -> false
  7844. | _ -> true
  7845. in
  7846. let configure = if is_synf then DynamicFieldAccess.configure_as_synf else DynamicFieldAccess.configure in
  7847. let maybe_hash = if ctx.rcf_optimize then fun str pos -> Some (hash_field_i32 ctx pos str) else fun str pos -> None in
  7848. configure gen (DynamicFieldAccess.abstract_implementation gen is_dynamic
  7849. (* print_endline *)
  7850. (fun expr fexpr field set is_unsafe ->
  7851. let hash = maybe_hash field fexpr.epos in
  7852. ctx.rcf_on_getset_field expr fexpr field hash set is_unsafe
  7853. )
  7854. (fun ecall fexpr field call_list ->
  7855. let hash = maybe_hash field fexpr.epos in
  7856. ctx.rcf_on_call_field ecall fexpr field hash call_list
  7857. )
  7858. );
  7859. ()
  7860. let replace_reflection ctx cl =
  7861. let gen = ctx.rcf_gen in
  7862. let pos = cl.cl_pos in
  7863. let this_t = TInst(cl, List.map snd cl.cl_params) in
  7864. let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
  7865. let last_fields = match cl.cl_super with
  7866. | None -> PMap.empty
  7867. | Some (super,_) -> super.cl_fields
  7868. in
  7869. let new_fields = ref [] in
  7870. let process_cf static cf =
  7871. match cf.cf_kind with
  7872. | Var _ -> ()
  7873. | _ when Meta.has Meta.ReplaceReflection cf.cf_meta ->
  7874. let name = if String.get cf.cf_name 0 = '_' then String.sub cf.cf_name 1 (String.length cf.cf_name - 1) else cf.cf_name in
  7875. let new_name = gen.gmk_internal_name "hx" name in
  7876. let new_cf = mk_class_field new_name cf.cf_type cf.cf_public cf.cf_pos cf.cf_kind cf.cf_params in
  7877. let fn_args, ret = get_fun (follow cf.cf_type) in
  7878. let tf_args = List.map (fun (name,_,t) -> alloc_var name t, None) fn_args in
  7879. let is_void = is_void ret in
  7880. let expr = {
  7881. eexpr = TCall(
  7882. {
  7883. eexpr = (if static then TField(mk_classtype_access cl pos, FStatic(cl, cf)) else TField(this, FInstance(cl, List.map snd cl.cl_params, cf)));
  7884. etype = cf.cf_type;
  7885. epos = cf.cf_pos;
  7886. },
  7887. List.map (fun (v,_) -> mk_local v cf.cf_pos) tf_args);
  7888. etype = ret;
  7889. epos = cf.cf_pos
  7890. } in
  7891. let new_f =
  7892. {
  7893. tf_args = tf_args;
  7894. tf_type = ret;
  7895. tf_expr = {
  7896. eexpr = TBlock([if is_void then expr else mk_return expr]);
  7897. etype = ret;
  7898. epos = pos;
  7899. }
  7900. } in
  7901. new_cf.cf_expr <- Some({ eexpr = TFunction(new_f); etype = cf.cf_type; epos = cf.cf_pos});
  7902. new_fields := new_cf :: !new_fields;
  7903. (if static then cl.cl_statics <- PMap.add new_name new_cf cl.cl_statics else cl.cl_fields <- PMap.add new_name new_cf cl.cl_fields);
  7904. if not static && PMap.mem new_name last_fields then cl.cl_overrides <- new_cf :: cl.cl_overrides
  7905. | _ -> ()
  7906. in
  7907. List.iter (process_cf false) cl.cl_ordered_fields;
  7908. cl.cl_ordered_fields <- cl.cl_ordered_fields @ !new_fields;
  7909. new_fields := [];
  7910. List.iter (process_cf true) cl.cl_ordered_statics;
  7911. cl.cl_ordered_statics <- cl.cl_ordered_statics @ !new_fields
  7912. (* ******************************************* *)
  7913. (* UniversalBaseClass *)
  7914. (* ******************************************* *)
  7915. (*
  7916. Sets the universal base class for hxgen types (HxObject / IHxObject)
  7917. dependencies:
  7918. As a rule, it should be one of the last module filters to run so any @:hxgen class created in the process
  7919. -Should- only run after TypeParams.RealTypeParams.Modf, since
  7920. *)
  7921. module UniversalBaseClass =
  7922. struct
  7923. let name = "rcf_universal_base_class"
  7924. let priority = min_dep +. 10.
  7925. let default_implementation gen baseclass baseinterface basedynamic =
  7926. (* baseinterface.cl_meta <- (Meta.BaseInterface, [], baseinterface.cl_pos) :: baseinterface.cl_meta; *)
  7927. let rec run md =
  7928. (if is_hxgen md then
  7929. match md with
  7930. | TClassDecl ( { cl_interface = true } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && cl.cl_path <> basedynamic.cl_path ->
  7931. cl.cl_implements <- (baseinterface, []) :: cl.cl_implements
  7932. | TClassDecl ({ cl_kind = KAbstractImpl _ } as cl) ->
  7933. (*
  7934. TODO: probably here is not the best place to add @:final to KAbstractImpl, also:
  7935. Doesn't it make sense to add @:final to KAbstractImpls on all platforms?
  7936. *)
  7937. if not (Meta.has Meta.Final cl.cl_meta) then cl.cl_meta <- (Meta.Final, [], cl.cl_pos) :: cl.cl_meta
  7938. | TClassDecl ( { cl_super = None } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && cl.cl_path <> basedynamic.cl_path ->
  7939. if is_some cl.cl_dynamic then
  7940. cl.cl_super <- Some (basedynamic,[])
  7941. else
  7942. cl.cl_super <- Some (baseclass,[])
  7943. | TClassDecl ( { cl_super = Some(super,_) } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && not ( is_hxgen (TClassDecl super) ) ->
  7944. cl.cl_implements <- (baseinterface, []) :: cl.cl_implements
  7945. | _ -> ()
  7946. );
  7947. md
  7948. in
  7949. run
  7950. let configure gen mapping_func =
  7951. let map e = Some(mapping_func e) in
  7952. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  7953. let default_config gen baseclass baseinterface basedynamic =
  7954. let impl = (default_implementation gen baseclass baseinterface basedynamic) in
  7955. configure gen impl
  7956. end;;
  7957. (*
  7958. Priority: must run AFTER UniversalBaseClass
  7959. *)
  7960. let priority = solve_deps name [DAfter UniversalBaseClass.priority]
  7961. let configure ?slow_invoke ctx baseinterface =
  7962. let gen = ctx.rcf_gen in
  7963. let run = (fun md -> match md with
  7964. | TClassDecl cl when is_hxgen md && ( not cl.cl_interface || cl.cl_path = baseinterface.cl_path ) && (match cl.cl_kind with KAbstractImpl _ -> false | _ -> true) ->
  7965. (if Meta.has Meta.ReplaceReflection cl.cl_meta then replace_reflection ctx cl);
  7966. (implement_dynamics ctx cl);
  7967. (if not (PMap.mem (gen.gmk_internal_name "hx" "lookupField") cl.cl_fields) then implement_final_lookup ctx cl);
  7968. (if not (PMap.mem (gen.gmk_internal_name "hx" "getField") cl.cl_fields) then implement_get_set ctx cl);
  7969. (if not (PMap.mem (gen.gmk_internal_name "hx" "invokeField") cl.cl_fields) then implement_invokeField ctx ~slow_invoke:slow_invoke cl);
  7970. (if not (PMap.mem (gen.gmk_internal_name "hx" "classFields") cl.cl_fields) then implement_fields ctx cl);
  7971. (if ctx.rcf_handle_statics && not (PMap.mem (gen.gmk_internal_name "hx" "getClassStatic") cl.cl_statics) then implement_get_class ctx cl);
  7972. (if not cl.cl_interface && not (PMap.mem (gen.gmk_internal_name "hx" "create") cl.cl_fields) then implement_create_empty ctx cl);
  7973. None
  7974. | _ -> None)
  7975. in
  7976. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) run
  7977. end;;
  7978. (* ******************************************* *)
  7979. (* Object Declaration Mapper *)
  7980. (* ******************************************* *)
  7981. (*
  7982. A simple Object Declaration Mapper. By default it will be a syntax filter, which only runs
  7983. after
  7984. dependencies:
  7985. *)
  7986. module ObjectDeclMap =
  7987. struct
  7988. let name = "object_decl_map"
  7989. let priority = solve_deps name []
  7990. let traverse gen map_fn =
  7991. let rec run e =
  7992. match e.eexpr with
  7993. | TObjectDecl odecl ->
  7994. let e = Type.map_expr run e in
  7995. (match e.eexpr with | TObjectDecl odecl -> map_fn e odecl | _ -> assert false)
  7996. | _ -> Type.map_expr run e
  7997. in
  7998. run
  7999. let configure gen (mapping_func:texpr->texpr) =
  8000. let map e = Some(mapping_func e) in
  8001. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  8002. end;;
  8003. (* ******************************************* *)
  8004. (* EnumToClass *)
  8005. (* ******************************************* *)
  8006. (*
  8007. For languages that don't support parameterized enums and/or metadata in enums, we need to transform
  8008. enums into normal classes. This is done at the first module pass by creating new classes with the same
  8009. path inside the modules, and removing the actual enum module by setting it as en extern.
  8010. Later, on the last expression pass, it will transform the TMatch codes into TSwitch. it will introduce a new
  8011. dependency, though:
  8012. * The target must create its own strategy to deal with reflection. As it is right now, we will have a base class
  8013. which the class will extend, create @:$IsEnum metadata for the class, and create @:alias() metadatas for the fields,
  8014. with their tag order (as a string) as their alias. If you are using ReflectionCFs, then you don't have to worry
  8015. about that, as it's already generating all information needed by the haxe runtime.
  8016. so they can be
  8017. dependencies:
  8018. The MatchToSwitch part must run after ExprStatementUnwrap as modified expressions might confuse it (not so true anymore)
  8019. *)
  8020. module EnumToClass =
  8021. struct
  8022. let name = "enum_to_class"
  8023. let priority = solve_deps name []
  8024. type t = {
  8025. ec_tbl : (path, tclass) Hashtbl.t;
  8026. }
  8027. let new_t () =
  8028. {
  8029. ec_tbl = Hashtbl.create 10
  8030. }
  8031. (* ******************************************* *)
  8032. (* EnumToClassModf *)
  8033. (* ******************************************* *)
  8034. (*
  8035. The actual Module Filter that will transform the enum into a class
  8036. dependencies:
  8037. Should run before ReflectionCFs, in order to enable proper reflection access.
  8038. Should run before TypeParams.RealTypeParams.RealTypeParamsModf, since generic enums must be first converted to generic classes
  8039. It needs that the target platform implements __array__() as a shortcut to declare haxe.ds.Vector
  8040. *)
  8041. module EnumToClassModf =
  8042. struct
  8043. let name = "enum_to_class_mod"
  8044. let priority = solve_deps name [DBefore ReflectionCFs.priority; DBefore TypeParams.RealTypeParams.RealTypeParamsModf.priority]
  8045. let pmap_exists fn pmap = try PMap.iter (fun a b -> if fn a b then raise Exit) pmap; false with | Exit -> true
  8046. let has_any_meta en =
  8047. let has_meta meta = List.exists (fun (m,_,_) -> match m with Meta.Custom _ -> true | _ -> false) meta in
  8048. has_meta en.e_meta || pmap_exists (fun _ ef -> has_meta ef.ef_meta) en.e_constrs
  8049. let convert gen t base_class base_param_class en should_be_hxgen handle_type_params =
  8050. let basic = gen.gcon.basic in
  8051. let pos = en.e_pos in
  8052. (* create the class *)
  8053. let cl = mk_class en.e_module en.e_path pos in
  8054. Hashtbl.add t.ec_tbl en.e_path cl;
  8055. (match Codegen.build_metadata gen.gcon (TEnumDecl en) with
  8056. | Some expr ->
  8057. let cf = mk_class_field "__meta__" expr.etype false expr.epos (Var { v_read = AccNormal; v_write = AccNormal }) [] in
  8058. cf.cf_expr <- Some expr;
  8059. cl.cl_statics <- PMap.add "__meta__" cf cl.cl_statics;
  8060. cl.cl_ordered_statics <- cf :: cl.cl_ordered_statics
  8061. | _ -> ()
  8062. );
  8063. let super, has_params = if Meta.has Meta.FlatEnum en.e_meta then base_class, false else base_param_class, true in
  8064. cl.cl_super <- Some(super,[]);
  8065. cl.cl_extern <- en.e_extern;
  8066. en.e_meta <- (Meta.Class, [], pos) :: en.e_meta;
  8067. cl.cl_module <- en.e_module;
  8068. cl.cl_meta <- ( Meta.Enum, [], pos ) :: cl.cl_meta;
  8069. (match gen.gcon.platform with
  8070. | Cs when Common.defined gen.gcon Define.CoreApiSerialize ->
  8071. cl.cl_meta <- ( Meta.Meta, [ (EField( (EConst (Ident "System"), null_pos ), "Serializable" ), null_pos) ], null_pos ) :: cl.cl_meta
  8072. | _ -> ());
  8073. let c_types =
  8074. if handle_type_params then
  8075. List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) en.e_params
  8076. else
  8077. []
  8078. in
  8079. cl.cl_params <- c_types;
  8080. let i = ref 0 in
  8081. let cfs = List.map (fun name ->
  8082. let ef = PMap.find name en.e_constrs in
  8083. let pos = ef.ef_pos in
  8084. let old_i = !i in
  8085. incr i;
  8086. let cf = match follow ef.ef_type with
  8087. | TFun(params,ret) ->
  8088. let dup_types =
  8089. if handle_type_params then
  8090. List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) en.e_params
  8091. else
  8092. []
  8093. in
  8094. let ef_type =
  8095. let fn, types = if handle_type_params then snd, dup_types else (fun _ -> t_dynamic), en.e_params in
  8096. let t = apply_params en.e_params (List.map fn types) ef.ef_type in
  8097. apply_params ef.ef_params (List.map fn ef.ef_params) t
  8098. in
  8099. let params, ret = get_fun ef_type in
  8100. let cf_params = if handle_type_params then dup_types @ ef.ef_params else [] in
  8101. let cf = mk_class_field name ef_type true pos (Method MethNormal) cf_params in
  8102. cf.cf_meta <- [];
  8103. let tf_args = List.map (fun (name,opt,t) -> (alloc_var name t, if opt then Some TNull else None) ) params in
  8104. let arr_decl = mk_nativearray_decl gen t_dynamic (List.map (fun (v,_) -> mk_local v pos) tf_args) pos in
  8105. let expr = {
  8106. eexpr = TFunction({
  8107. tf_args = tf_args;
  8108. tf_type = ret;
  8109. tf_expr = mk_block ( mk_return { eexpr = TNew(cl,List.map snd dup_types, [mk_int gen old_i pos; arr_decl] ); etype = TInst(cl, List.map snd dup_types); epos = pos } );
  8110. });
  8111. etype = ef_type;
  8112. epos = pos
  8113. } in
  8114. cf.cf_expr <- Some expr;
  8115. cf
  8116. | _ ->
  8117. let actual_t = match follow ef.ef_type with
  8118. | TEnum(e, p) -> TEnum(e, List.map (fun _ -> t_dynamic) p)
  8119. | _ -> assert false
  8120. in
  8121. let cf = mk_class_field name actual_t true pos (Var { v_read = AccNormal; v_write = AccNever }) [] in
  8122. let args = if has_params then
  8123. [mk_int gen old_i pos; null (gen.gclasses.nativearray t_dynamic) pos]
  8124. else
  8125. [mk_int gen old_i pos]
  8126. in
  8127. cf.cf_meta <- [Meta.ReadOnly,[],pos];
  8128. cf.cf_expr <- Some {
  8129. eexpr = TNew(cl, List.map (fun _ -> t_empty) cl.cl_params, args);
  8130. etype = TInst(cl, List.map (fun _ -> t_empty) cl.cl_params);
  8131. epos = pos;
  8132. };
  8133. cf
  8134. in
  8135. cl.cl_statics <- PMap.add cf.cf_name cf cl.cl_statics;
  8136. cf
  8137. ) en.e_names in
  8138. let constructs_cf = mk_class_field "__hx_constructs" (gen.gclasses.nativearray basic.tstring) true pos (Var { v_read = AccNormal; v_write = AccNever }) [] in
  8139. constructs_cf.cf_meta <- [Meta.ReadOnly,[],pos];
  8140. constructs_cf.cf_expr <- Some (mk_nativearray_decl gen basic.tstring (List.map (fun s -> { eexpr = TConst(TString s); etype = basic.tstring; epos = pos }) en.e_names) pos);
  8141. cl.cl_ordered_statics <- constructs_cf :: cfs @ cl.cl_ordered_statics ;
  8142. cl.cl_statics <- PMap.add "__hx_constructs" constructs_cf cl.cl_statics;
  8143. let getTag_cf_type = tfun [] basic.tstring in
  8144. let getTag_cf = mk_class_field "getTag" getTag_cf_type true pos (Method MethNormal) [] in
  8145. getTag_cf.cf_meta <- [(Meta.Final, [], pos)];
  8146. getTag_cf.cf_expr <- Some {
  8147. eexpr = TFunction {
  8148. tf_args = [];
  8149. tf_type = basic.tstring;
  8150. tf_expr = {
  8151. eexpr = TReturn (Some (
  8152. let e_constructs = mk_static_field_access_infer cl "__hx_constructs" pos [] in
  8153. let e_this = mk (TConst TThis) (TInst (cl,[])) pos in
  8154. let e_index = mk_field_access gen e_this "index" pos in
  8155. {
  8156. eexpr = TArray(e_constructs,e_index);
  8157. etype = basic.tstring;
  8158. epos = pos;
  8159. }
  8160. ));
  8161. epos = pos;
  8162. etype = basic.tvoid;
  8163. }
  8164. };
  8165. etype = getTag_cf_type;
  8166. epos = pos;
  8167. };
  8168. cl.cl_ordered_fields <- getTag_cf :: cl.cl_ordered_fields ;
  8169. cl.cl_fields <- PMap.add "getTag" getTag_cf cl.cl_fields;
  8170. cl.cl_overrides <- getTag_cf :: cl.cl_overrides;
  8171. if should_be_hxgen then
  8172. cl.cl_meta <- (Meta.HxGen,[],cl.cl_pos) :: cl.cl_meta
  8173. else
  8174. cl.cl_meta <- (Meta.NativeGen,[],cl.cl_pos) :: cl.cl_meta;
  8175. gen.gadd_to_module (TClassDecl cl) (max_dep);
  8176. TEnumDecl en
  8177. (*
  8178. traverse
  8179. gen - gen context
  8180. convert_all : bool - should we convert all enums? If set, convert_if_has_meta will be ignored.
  8181. convert_if_has_meta : bool - should we convert only if it has meta?
  8182. enum_base_class : tclass - the enum base class.
  8183. should_be_hxgen : bool - should the created enum be hxgen?
  8184. *)
  8185. let traverse gen t convert_all convert_if_has_meta enum_base_class param_enum_class should_be_hxgen handle_tparams =
  8186. let convert e = convert gen t enum_base_class param_enum_class e should_be_hxgen handle_tparams in
  8187. let run md = match md with
  8188. | TEnumDecl e when is_hxgen md ->
  8189. if convert_all then
  8190. convert e
  8191. else if convert_if_has_meta && has_any_meta e then
  8192. convert e
  8193. else if not (Meta.has Meta.FlatEnum e.e_meta) then
  8194. convert e
  8195. else begin
  8196. (* take off the :hxgen meta from it, if there's any *)
  8197. e.e_meta <- List.filter (fun (n,_,_) -> not (n = Meta.HxGen)) e.e_meta;
  8198. md
  8199. end
  8200. | _ -> md
  8201. in
  8202. run
  8203. let configure gen (mapping_func:module_type->module_type) =
  8204. let map md = Some(mapping_func md) in
  8205. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  8206. end;;
  8207. (* ******************************************* *)
  8208. (* EnumToClassExprf *)
  8209. (* ******************************************* *)
  8210. (*
  8211. Enum to class Expression Filter
  8212. will convert TMatch into TSwitch
  8213. dependencies:
  8214. Should run before TArrayTransform, since it generates array access expressions
  8215. *)
  8216. module EnumToClassExprf =
  8217. struct
  8218. let name = "enum_to_class_exprf"
  8219. let priority = solve_deps name [DBefore TArrayTransform.priority]
  8220. let traverse gen t opt_get_native_enum_tag =
  8221. let rec run e =
  8222. let get_converted_enum_type et =
  8223. let en, eparams = match follow (gen.gfollow#run_f et) with
  8224. | TEnum(en,p) -> en, p
  8225. | _ -> raise Not_found
  8226. in
  8227. let cl = Hashtbl.find t.ec_tbl en.e_path in
  8228. TInst(cl, eparams)
  8229. in
  8230. match e.eexpr with
  8231. | TCall (({eexpr = TField(_, FStatic({cl_path=[],"Type"},{cf_name="enumIndex"}))} as left), [f]) ->
  8232. let f = run f in
  8233. (try
  8234. mk_field_access gen {f with etype = get_converted_enum_type f.etype} "index" e.epos
  8235. with Not_found ->
  8236. { e with eexpr = TCall(left, [f]) })
  8237. | TEnumParameter(f, _,i) ->
  8238. let f = run f in
  8239. (* check if en was converted to class *)
  8240. (* if it was, switch on tag field and change cond type *)
  8241. let f = try
  8242. { f with etype = get_converted_enum_type f.etype }
  8243. with Not_found ->
  8244. f
  8245. in
  8246. let cond_array = { (mk_field_access gen f "params" f.epos) with etype = gen.gclasses.nativearray t_dynamic } in
  8247. { e with eexpr = TArray(cond_array, mk_int gen i cond_array.epos); }
  8248. | _ -> Type.map_expr run e
  8249. in
  8250. run
  8251. let configure gen (mapping_func:texpr->texpr) =
  8252. let map e = Some(mapping_func e) in
  8253. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
  8254. end;;
  8255. let configure gen opt_get_native_enum_tag convert_all convert_if_has_meta enum_base_class param_enum_class should_be_hxgen handle_tparams =
  8256. let t = new_t () in
  8257. EnumToClassModf.configure gen (EnumToClassModf.traverse gen t convert_all convert_if_has_meta enum_base_class param_enum_class should_be_hxgen handle_tparams);
  8258. EnumToClassExprf.configure gen (EnumToClassExprf.traverse gen t opt_get_native_enum_tag)
  8259. end;;
  8260. (* ******************************************* *)
  8261. (* IteratorsInterface *)
  8262. (* ******************************************* *)
  8263. (*
  8264. This module will handle with Iterators, Iterables and TFor() expressions.
  8265. At first, a module filter will receive a Iterator<T> and Iterable<T> interface, which will be implemented
  8266. if hasNext(), next() or iterator() fields are detected with the correct type.
  8267. At this part a custom function will be called which can adequate the class fields so they are compatible with
  8268. native Iterators as well
  8269. The expression filter part of this module will look for TFor() expressions, and transform like that:
  8270. for (anInt in value.iterator())
  8271. {
  8272. }
  8273. {
  8274. var s:haxe.lang.Iterator<Int> = ExternalFunction.getIterator(value.iterator());
  8275. while (s.hasNext())
  8276. {
  8277. var anInt:Int = s.next();
  8278. }
  8279. }
  8280. dependencies:
  8281. None.
  8282. *)
  8283. module IteratorsInterface =
  8284. struct
  8285. let name = "iterators_interface"
  8286. (* TODO later
  8287. (* ******************************************* *)
  8288. (* IteratorsInterfaceModf *)
  8289. (* ******************************************* *)
  8290. (*
  8291. The module filter for Iterators Interface, which will implement the iterator/iterable interface on each
  8292. class that conforms with the typedefs Iterator<> and Iterable<>
  8293. It's a very simple module and it will rely on cast detection to work correctly. This is so that
  8294. when the
  8295. dependencies:
  8296. Must run at the Module Filters, so cast detection can detect a cast to the interface and we can
  8297. *)
  8298. module IteratorsInterfaceModf =
  8299. struct
  8300. let name = "iterators_interface_modf"
  8301. let conforms_cfs has_next next =
  8302. try (match follow has_next.cf_type with
  8303. | TFun([],ret) when
  8304. (match follow ret with | TAbstract({ a_path = ([], "Bool") }, []) -> () | _ -> raise Not_found) ->
  8305. ()
  8306. | _ -> raise Not_found);
  8307. (match follow next.cf_type with
  8308. | TFun([], ret) -> ret
  8309. | _ -> raise Not_found
  8310. )
  8311. let conforms_type_iterator t =
  8312. try match follow t with
  8313. | TInst(cl,params) ->
  8314. let has_next = PMap.find "hasNext" cl.cl_fields in
  8315. let next = PMap.find "next" cl.cl_fields in
  8316. Some (conforms_cfs has_next next)
  8317. | TAnon(anon) ->
  8318. let has_next = PMap.find "hasNext" anon.a_fields in
  8319. let next = PMap.find "next" anon.a_fields in
  8320. Some (conforms_cfs has_next next)
  8321. | _ -> None
  8322. with | Not_found -> None
  8323. let conforms_as_iterable cl =
  8324. try
  8325. let iterator = PMap.find "iterator" cl.cl_fields in
  8326. match follow iterator.cf_type with
  8327. | TFun([], ret) -> conforms_type_iterator ret
  8328. | _ -> None
  8329. with | Not_found -> None
  8330. let conforms_as_iterator cl =
  8331. try
  8332. let has_next = PMap.find "hasNext" cl.cl_fields in
  8333. let next = PMap.find "next" cl.cl_fields in
  8334. Some (conforms_cfs has_next next)
  8335. with | Not_found -> None
  8336. let priority = solve_deps name []
  8337. let traverse gen iterator_iface iterable_iface on_found_iterator on_found_iterable =
  8338. let rec run md =
  8339. match md with
  8340. | TClassDecl cl when not cl.cl_extern && is_hxgen cl ->
  8341. let conforms_iterator = conforms_as_iterator cl in
  8342. let conforms_iterable = conforms_as_iterable cl in
  8343. if is_some conforms_iterator then begin
  8344. let it_t = get conforms_iterator in
  8345. cl.cl_interfaces <- (iterator_iface, [it_t]);
  8346. on_found_iterator cl
  8347. end;
  8348. if is_some conforms_iterable then begin
  8349. let it_t = get conforms_iterable in
  8350. cl.cl_interfaces <- (iterable_iface, [it_t]);
  8351. on_found_iterable cl
  8352. end;
  8353. md
  8354. | _ -> md
  8355. in
  8356. run
  8357. let configure gen (mapping_func:texpr->texpr) =
  8358. let map e = Some(mapping_func e) in
  8359. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
  8360. end;;
  8361. *)
  8362. (* ******************************************* *)
  8363. (* IteratorsInterfaceExprf *)
  8364. (* ******************************************* *)
  8365. (*
  8366. The expression filter for Iterators. Will look for TFor, transform it into
  8367. {
  8368. var iterator = // in expression here
  8369. while (iterator.hasNext())
  8370. {
  8371. var varName = iterator.next();
  8372. }
  8373. }
  8374. dependencies:
  8375. Must run before Dynamic fields access is run
  8376. *)
  8377. module IteratorsInterfaceExprf =
  8378. struct
  8379. let name = "iterators_interface_exprf"
  8380. let priority = solve_deps name [DBefore DynamicFieldAccess.priority]
  8381. let priority_as_synf = solve_deps name [DBefore DynamicFieldAccess.priority_as_synf]
  8382. let mk_access gen v name pos =
  8383. let field_t =
  8384. try match follow v.v_type with
  8385. | TInst(cl, params) ->
  8386. let field = PMap.find name cl.cl_fields in
  8387. apply_params cl.cl_params params field.cf_type
  8388. | TAnon(anon) ->
  8389. let field = PMap.find name anon.a_fields in
  8390. field.cf_type
  8391. | _ -> t_dynamic
  8392. with | Not_found -> t_dynamic
  8393. in
  8394. { (mk_field_access gen (mk_local v pos) name pos) with etype = field_t }
  8395. let traverse gen change_in_expr =
  8396. let basic = gen.gcon.basic in
  8397. let rec run e =
  8398. match e.eexpr with
  8399. | TFor(var, in_expr, block) ->
  8400. let in_expr = change_in_expr (run in_expr) in
  8401. let temp = mk_temp gen "iterator" in_expr.etype in
  8402. let block =
  8403. [
  8404. { eexpr = TVar(temp, Some(in_expr)); etype = basic.tvoid; epos = in_expr.epos };
  8405. {
  8406. eexpr = TWhile(
  8407. { eexpr = TCall(mk_access gen temp "hasNext" in_expr.epos, []); etype = basic.tbool; epos = in_expr.epos },
  8408. Type.concat ({
  8409. eexpr = TVar(var, Some({ eexpr = TCall(mk_access gen temp "next" in_expr.epos, []); etype = var.v_type; epos = in_expr.epos }));
  8410. etype = basic.tvoid;
  8411. epos = in_expr.epos
  8412. }) ( run block ),
  8413. Ast.NormalWhile);
  8414. etype = basic.tvoid;
  8415. epos = e.epos
  8416. }
  8417. ] in
  8418. { eexpr = TBlock(block); etype = e.etype; epos = e.epos }
  8419. | _ -> Type.map_expr run e
  8420. in
  8421. run
  8422. let configure gen (mapping_func:texpr->texpr) =
  8423. let map e = Some(mapping_func e) in
  8424. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
  8425. let configure_as_synf gen (mapping_func:texpr->texpr) =
  8426. let map e = Some(mapping_func e) in
  8427. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority_as_synf) map
  8428. end;;
  8429. let configure gen change_in_expr =
  8430. IteratorsInterfaceExprf.configure gen (IteratorsInterfaceExprf.traverse gen change_in_expr)
  8431. let configure_as_synf gen change_in_expr =
  8432. IteratorsInterfaceExprf.configure_as_synf gen (IteratorsInterfaceExprf.traverse gen change_in_expr)
  8433. end;;
  8434. (* ******************************************* *)
  8435. (* SwitchToIf *)
  8436. (* ******************************************* *)
  8437. (*
  8438. Just a syntax filter which changes switch expressions to if() else if() else if() ...
  8439. It can be also an expression filter
  8440. dependencies:
  8441. *)
  8442. module SwitchToIf =
  8443. struct
  8444. let name = "switch_to_if"
  8445. let priority = solve_deps name []
  8446. let rec simplify_expr e = match e.eexpr with
  8447. | TParenthesis e
  8448. | TMeta(_,e) -> simplify_expr e
  8449. | _ -> e
  8450. let traverse gen (should_convert:texpr->bool) (handle_nullables:bool) =
  8451. let basic = gen.gcon.basic in
  8452. let rec run e =
  8453. match e.eexpr with
  8454. | TSwitch(cond,cases,default) when should_convert e ->
  8455. let cond_etype, should_cache = match handle_nullables, gen.gfollow#run_f cond.etype with
  8456. | true, TType({ t_path = ([], "Null") }, [t]) ->
  8457. let rec take_off_nullable t = match gen.gfollow#run_f t with
  8458. | TType({ t_path = ([], "Null") }, [t]) -> take_off_nullable t
  8459. | _ -> t
  8460. in
  8461. take_off_nullable t, true
  8462. | _, _ -> cond.etype, false
  8463. in
  8464. if should_cache && not (should_convert { e with eexpr = TSwitch({ cond with etype = cond_etype }, cases, default) }) then begin
  8465. { e with eexpr = TSwitch(mk_cast cond_etype (run cond), List.map (fun (cs,e) -> (List.map run cs, run e)) cases, Option.map run default) }
  8466. end else begin
  8467. let local, fst_block = match cond.eexpr, should_cache with
  8468. | TLocal _, false -> cond, []
  8469. | _ ->
  8470. let var = mk_temp gen "switch" cond_etype in
  8471. let cond = run cond in
  8472. let cond = if should_cache then mk_cast cond_etype cond else cond in
  8473. mk_local var cond.epos, [ { eexpr = TVar(var,Some(cond)); etype = basic.tvoid; epos = cond.epos } ]
  8474. in
  8475. let mk_eq cond =
  8476. { eexpr = TBinop(Ast.OpEq, local, cond); etype = basic.tbool; epos = cond.epos }
  8477. in
  8478. let rec mk_many_cond conds =
  8479. match conds with
  8480. | cond :: [] ->
  8481. mk_eq cond
  8482. | cond :: tl ->
  8483. { eexpr = TBinop(Ast.OpBoolOr, mk_eq (run cond), mk_many_cond tl); etype = basic.tbool; epos = cond.epos }
  8484. | [] -> assert false
  8485. in
  8486. let mk_many_cond conds =
  8487. let ret = mk_many_cond conds in
  8488. (*
  8489. this might be considered a hack. But since we're on a syntax filter and
  8490. the condition is guaranteed to not have run twice, we can really run the
  8491. expr filters again for it (so to change e.g. OpEq accordingly
  8492. *)
  8493. gen.gexpr_filters#run_f ret
  8494. in
  8495. let rec loop cases = match cases with
  8496. | (conds,e) :: [] ->
  8497. { eexpr = TIf(mk_many_cond conds, run e, Option.map run default); etype = e.etype; epos = e.epos }
  8498. | (conds,e) :: tl ->
  8499. { eexpr = TIf(mk_many_cond conds, run e, Some(loop tl)); etype = e.etype; epos = e.epos }
  8500. | [] -> match default with
  8501. | None ->
  8502. raise Exit
  8503. | Some d -> run d
  8504. in
  8505. try
  8506. { e with eexpr = TBlock(fst_block @ [loop cases]) }
  8507. with | Exit ->
  8508. { e with eexpr = TBlock [] }
  8509. end
  8510. | TSwitch(cond,cases,default) -> (try
  8511. match (simplify_expr cond).eexpr with
  8512. | TCall( { eexpr = TField(_,FStatic({ cl_path = [],"Type" }, { cf_name = "enumIndex" })) }, [enum] ) ->
  8513. let real_enum = match enum.etype with
  8514. | TEnum(e,_) -> e
  8515. | _ -> raise Not_found
  8516. in
  8517. if Meta.has Meta.Class real_enum.e_meta then raise Not_found;
  8518. let enum_expr = mk_mt_access (TEnumDecl(real_enum)) e.epos in
  8519. let fields = Hashtbl.create (List.length real_enum.e_names) in
  8520. PMap.iter (fun _ ef -> Hashtbl.add fields ef.ef_index ef) real_enum.e_constrs;
  8521. let cases = List.map (fun (el,e) ->
  8522. List.map (fun e -> match e.eexpr with
  8523. | TConst(TInt i) ->
  8524. let ef = Hashtbl.find fields (Int32.to_int i) in
  8525. { e with eexpr = TField(enum_expr, FEnum(real_enum,ef)); etype = TEnum(real_enum,List.map (fun _ -> t_dynamic) real_enum.e_params) }
  8526. | _ -> raise Not_found) el, run e
  8527. ) cases in
  8528. { e with eexpr = TSwitch(enum,cases,Option.map run default) }
  8529. | _ -> raise Not_found
  8530. with Not_found -> Type.map_expr run e)
  8531. | _ -> Type.map_expr run e
  8532. in
  8533. run
  8534. let configure gen (mapping_func:texpr->texpr) =
  8535. let map e = Some(mapping_func e) in
  8536. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  8537. end;;
  8538. (* ******************************************* *)
  8539. (* Anonymous Class object handling *)
  8540. (* ******************************************* *)
  8541. (*
  8542. (syntax)
  8543. When we pass a class as an object, in some languages we will need a special construct to be able to
  8544. access its statics as if they were normal object fields. On C# and Java the way found to do that is
  8545. by handling statics reflection also by a normal instance. This also happens in hxcpp and neko, so I
  8546. guess it's a valid practice.
  8547. So if we want to handle the reflection of the static MyClass, here's roughly how it will be done:
  8548. var x = MyClass;
  8549. gets converted into
  8550. Haxe.Lang.Class x = Haxe.Lang.Runtime.GetType(typeof(MyClass).RuntimeHandle);
  8551. which will in turn look in its cache but roughly would do:
  8552. Haxe.Lang.Class x = new Haxe.Lang.Class(new MyClass(EmptyObject.EMPTY));
  8553. This module will of course let the caller choose how this will be implemented. It will just identify all
  8554. uses of class that will require it to be cast as an object.
  8555. dependencies:
  8556. *)
  8557. module ClassInstance =
  8558. struct
  8559. let priority = solve_deps "class_instance" []
  8560. let traverse gen (change_expr:texpr->module_type->texpr) =
  8561. let rec run e =
  8562. match e.eexpr with
  8563. | TCall( ({ eexpr = TLocal({ v_name = ("__is__" | "__as__" | "__typeof__") } as v) } as local), calls ) when Hashtbl.mem gen.gspecial_vars v.v_name ->
  8564. { e with eexpr = TCall(local, List.map (fun e ->
  8565. match e.eexpr with
  8566. | TTypeExpr _ -> e
  8567. | _ -> run e) calls) }
  8568. | TField({ eexpr = TTypeExpr(mt) }, f) ->
  8569. e
  8570. | TField(ef, f) ->
  8571. (match anon_class ef.etype with
  8572. | None -> Type.map_expr run e
  8573. | Some t ->
  8574. { e with eexpr = TField( { ef with eexpr = TTypeExpr(t) }, f) }
  8575. )
  8576. | TTypeExpr(mt) -> change_expr e mt
  8577. | _ -> Type.map_expr run e
  8578. in
  8579. run
  8580. let configure gen (mapping_func:texpr->texpr) =
  8581. let map e = Some(mapping_func e) in
  8582. gen.gsyntax_filters#add ~name:"class_instance" ~priority:(PCustom priority) map
  8583. end;;
  8584. (* ******************************************* *)
  8585. (* HardNullableSynf *)
  8586. (* ******************************************* *)
  8587. (*
  8588. This module will handle Null<T> types for languages that offer a way of dealing with
  8589. stack-allocated structures or tuples and generics. Essentialy on those targets a Null<T>
  8590. will be a tuple ( 'a * bool ), where bool is whether the value is null or not.
  8591. At first (configure-time), we will modify the follow function so it can follow correctly nested Null<Null<T>>,
  8592. and do not follow Null<T> to its underlying type
  8593. Then we will run a syntax filter, which will look for casts to Null<T> and replace them by
  8594. a call to the new Null<T> creation;
  8595. Also casts from Null<T> to T or direct uses of Null<T> (call, field access, array access, closure)
  8596. will result in the actual value being accessed
  8597. For compatibility with the C# target, HardNullable will accept both Null<T> and haxe.lang.Null<T> types
  8598. dependencies:
  8599. Needs to be run after all cast detection modules
  8600. *)
  8601. module HardNullableSynf =
  8602. struct
  8603. let name = "hard_nullable"
  8604. let priority = solve_deps name [DAfter CastDetect.ReturnCast.priority]
  8605. let rec is_null_t gen t = match gen.greal_type t with
  8606. | TType( { t_path = ([], "Null") }, [of_t])
  8607. | TInst( { cl_path = (["haxe";"lang"], "Null") }, [of_t]) ->
  8608. let rec take_off_null t =
  8609. match is_null_t gen t with | None -> t | Some s -> take_off_null s
  8610. in
  8611. Some (take_off_null of_t)
  8612. | TMono r -> (match !r with | Some t -> is_null_t gen t | None -> None)
  8613. | TLazy f -> is_null_t gen (!f())
  8614. | TType (t, tl) ->
  8615. is_null_t gen (apply_params t.t_params tl t.t_type)
  8616. | _ -> None
  8617. let follow_addon gen t =
  8618. let rec strip_off_nullable t =
  8619. let t = gen.gfollow#run_f t in
  8620. match t with
  8621. (* haxe.lang.Null<haxe.lang.Null<>> wouldn't be a valid construct, so only follow Null<> *)
  8622. | TType ( { t_path = ([], "Null") }, [of_t] ) -> strip_off_nullable of_t
  8623. | _ -> t
  8624. in
  8625. match t with
  8626. | TType( ({ t_path = ([], "Null") } as tdef), [of_t]) ->
  8627. Some( TType(tdef, [ strip_off_nullable of_t ]) )
  8628. | _ -> None
  8629. let traverse gen unwrap_null wrap_val null_to_dynamic has_value opeq_handler handle_opeq handle_cast =
  8630. (* let unwrap_null e = *)
  8631. (* let ret = unwrap_null e in *)
  8632. (* { ret with eexpr = TParenthesis(ret) } *)
  8633. (* in *)
  8634. (* let wrap_val e t b = *)
  8635. (* let ret = wrap_val e t b in *)
  8636. (* { ret with eexpr = TParenthesis(ret) } *)
  8637. (* in *)
  8638. let is_string t = match gen.greal_type t with
  8639. | TInst({ cl_path=([],"String") },_) -> true
  8640. | _ -> false
  8641. in
  8642. let handle_unwrap to_t e =
  8643. let e_null_t = get (is_null_t gen e.etype) in
  8644. match gen.greal_type to_t with
  8645. | TDynamic _ | TMono _ | TAnon _ ->
  8646. (match e_null_t with
  8647. | TDynamic _ | TMono _ | TAnon _ ->
  8648. gen.ghandle_cast to_t e_null_t (unwrap_null e)
  8649. | _ -> null_to_dynamic e
  8650. )
  8651. | _ ->
  8652. gen.ghandle_cast to_t e_null_t (unwrap_null e)
  8653. in
  8654. let handle_wrap e t =
  8655. match e.eexpr with
  8656. | TConst(TNull) ->
  8657. wrap_val e t false
  8658. | _ ->
  8659. wrap_val e t true
  8660. in
  8661. let is_null_t = is_null_t gen in
  8662. let cur_block = ref [] in
  8663. let add_tmp v e p =
  8664. cur_block := { eexpr = TVar(v,e); etype = gen.gcon.basic.tvoid; epos = p } :: !cur_block
  8665. in
  8666. let get_local e = match e.eexpr with
  8667. | TLocal _ ->
  8668. e, e
  8669. | _ ->
  8670. let v = mk_temp gen "nulltmp" e.etype in
  8671. add_tmp v (Some (null e.etype e.epos)) e.epos;
  8672. let local = { e with eexpr = TLocal(v) } in
  8673. mk_paren { e with eexpr = TBinop(Ast.OpAssign, local, e) }, local
  8674. in
  8675. let rec run e =
  8676. match e.eexpr with
  8677. | TBlock(bl) ->
  8678. let lst = !cur_block in
  8679. cur_block := [];
  8680. List.iter (fun e ->
  8681. let e = run e in
  8682. cur_block := (e :: !cur_block)
  8683. ) bl;
  8684. let ret = !cur_block in
  8685. cur_block := lst;
  8686. { e with eexpr = TBlock(List.rev ret) }
  8687. | TCast(v, _) ->
  8688. let null_et = is_null_t e.etype in
  8689. let null_vt = is_null_t v.etype in
  8690. (match null_vt, null_et with
  8691. | Some(vt), None when is_string e.etype ->
  8692. let v = run v in
  8693. { e with eexpr = TCast(null_to_dynamic v,None) }
  8694. | Some(vt), None ->
  8695. (match v.eexpr with
  8696. (* is there an unnecessary cast to Nullable? *)
  8697. | TCast(v2, _) ->
  8698. run { v with etype = e.etype }
  8699. | _ ->
  8700. handle_unwrap e.etype (run v)
  8701. )
  8702. | None, Some(et) ->
  8703. handle_wrap (run v) et
  8704. | Some(vt), Some(et) when handle_cast ->
  8705. handle_wrap (gen.ghandle_cast et vt (handle_unwrap vt (run v))) et
  8706. | Some(vt), Some(et) when not (type_iseq (run_follow gen vt) (run_follow gen et)) ->
  8707. (* check if has value and convert *)
  8708. let vlocal_fst, vlocal = get_local (run v) in
  8709. {
  8710. eexpr = TIf(
  8711. has_value vlocal_fst,
  8712. handle_wrap (mk_cast et (unwrap_null vlocal)) et,
  8713. Some( handle_wrap (null et e.epos) et ));
  8714. etype = e.etype;
  8715. epos = e.epos
  8716. }
  8717. | _ ->
  8718. Type.map_expr run e
  8719. )
  8720. | TField(ef, field) when is_some (is_null_t ef.etype) ->
  8721. let to_t = get (is_null_t ef.etype) in
  8722. { e with eexpr = TField(handle_unwrap to_t (run ef), field) }
  8723. | TCall(ecall, params) when is_some (is_null_t ecall.etype) ->
  8724. let to_t = get (is_null_t ecall.etype) in
  8725. { e with eexpr = TCall(handle_unwrap to_t (run ecall), List.map run params) }
  8726. | TArray(earray, p) when is_some (is_null_t earray.etype) ->
  8727. let to_t = get (is_null_t earray.etype) in
  8728. { e with eexpr = TArray(handle_unwrap to_t (run earray), p) }
  8729. | TBinop(op, e1, e2) ->
  8730. let e1_t = is_null_t e1.etype in
  8731. let e2_t = is_null_t e2.etype in
  8732. (match op with
  8733. | Ast.OpAssign
  8734. | Ast.OpAssignOp _ ->
  8735. (match e1_t, e2_t with
  8736. | Some t1, Some t2 ->
  8737. (match op with
  8738. | Ast.OpAssign ->
  8739. Type.map_expr run e
  8740. | Ast.OpAssignOp op ->
  8741. (match e1.eexpr with
  8742. | TLocal _ ->
  8743. { e with eexpr = TBinop( Ast.OpAssign, e1, handle_wrap { e with eexpr = TBinop (op, handle_unwrap t1 e1, handle_unwrap t2 (run e2) ) } t1 ) }
  8744. | _ ->
  8745. let v, e1, evars = match e1.eexpr with
  8746. | TField(ef, f) ->
  8747. let v = mk_temp gen "nullbinop" ef.etype in
  8748. v, { e1 with eexpr = TField(mk_local v ef.epos, f) }, ef
  8749. | _ ->
  8750. let v = mk_temp gen "nullbinop" e1.etype in
  8751. v, mk_local v e1.epos, e1
  8752. in
  8753. { e with eexpr = TBlock([
  8754. { eexpr = TVar(v, Some evars); etype = gen.gcon.basic.tvoid; epos = e.epos };
  8755. { e with eexpr = TBinop( Ast.OpAssign, e1, handle_wrap { e with eexpr = TBinop (op, handle_unwrap t1 e1, handle_unwrap t2 (run e2) ) } t1 ) }
  8756. ]) }
  8757. )
  8758. | _ -> assert false
  8759. )
  8760. | _ ->
  8761. Type.map_expr run e (* casts are already dealt with normal CastDetection module *)
  8762. )
  8763. | Ast.OpEq | Ast.OpNotEq when not handle_opeq ->
  8764. Type.map_expr run e
  8765. | Ast.OpEq | Ast.OpNotEq ->
  8766. (match e1.eexpr, e2.eexpr with
  8767. | TConst(TNull), _ when is_some e2_t ->
  8768. let e = has_value (run e2) in
  8769. if op = Ast.OpEq then
  8770. { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) }
  8771. else
  8772. e
  8773. | _, TConst(TNull) when is_some e1_t ->
  8774. let e = has_value (run e1) in
  8775. if op = Ast.OpEq then
  8776. { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) }
  8777. else
  8778. e
  8779. | _ when is_some e1_t || is_some e2_t ->
  8780. let e1, e2 =
  8781. if not (is_some e1_t) then
  8782. run e2, handle_wrap (run e1) (get e2_t)
  8783. else if not (is_some e2_t) then
  8784. run e1, handle_wrap (run e2) (get e1_t)
  8785. else
  8786. run e1, run e2
  8787. in
  8788. let e = opeq_handler e1 e2 in
  8789. if op = Ast.OpEq then
  8790. { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) }
  8791. else
  8792. e
  8793. | _ ->
  8794. Type.map_expr run e
  8795. )
  8796. | Ast.OpAdd when is_string e1.etype || is_string e2.etype ->
  8797. let e1 = if is_some e1_t then
  8798. null_to_dynamic (run e1)
  8799. else
  8800. run e1
  8801. in
  8802. let e2 = if is_some e2_t then
  8803. null_to_dynamic (run e2)
  8804. else
  8805. run e2
  8806. in
  8807. let e_t = is_null_t e.etype in
  8808. if is_some e_t then
  8809. wrap_val { eexpr = TBinop(op,e1,e2); etype = get e_t; epos = e.epos } (get e_t) true
  8810. else
  8811. { e with eexpr = TBinop(op,e1,e2) }
  8812. | _ ->
  8813. let e1 = if is_some e1_t then
  8814. handle_unwrap (get e1_t) (run e1)
  8815. else run e1 in
  8816. let e2 = if is_some e2_t then
  8817. handle_unwrap (get e2_t) (run e2)
  8818. else
  8819. run e2 in
  8820. (* if it is Null<T>, we need to convert the result again to null *)
  8821. let e_t = (is_null_t e.etype) in
  8822. if is_some e_t then
  8823. wrap_val { eexpr = TBinop(op, e1, e2); etype = get e_t; epos = e.epos } (get e_t) true
  8824. else
  8825. { e with eexpr = TBinop(op, e1, e2) }
  8826. )
  8827. (*| TUnop( (Ast.Increment as op)*)
  8828. | _ -> Type.map_expr run e
  8829. in
  8830. let run e = match e.eexpr with
  8831. | TFunction tf ->
  8832. run { e with eexpr = TFunction { tf with tf_expr = mk_block tf.tf_expr } }
  8833. | TBlock _ ->
  8834. run e
  8835. | _ -> match run (mk_block e) with
  8836. | { eexpr = TBlock([e]) } -> e
  8837. | e -> e
  8838. in
  8839. run
  8840. let configure gen (mapping_func:texpr->texpr) =
  8841. gen.gfollow#add ~name:(name ^ "_follow") (follow_addon gen);
  8842. let map e = Some(mapping_func e) in
  8843. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  8844. end;;
  8845. (* ******************************************* *)
  8846. (* ArrayDeclSynf *)
  8847. (* ******************************************* *)
  8848. (*
  8849. A syntax filter that will change array declarations to the actual native array declarations plus
  8850. the haxe array initialization
  8851. dependencies:
  8852. Must run after ObjectDeclMap since it can add TArrayDecl expressions
  8853. *)
  8854. module ArrayDeclSynf =
  8855. struct
  8856. let name = "array_decl_synf"
  8857. let priority = solve_deps name [DAfter ObjectDeclMap.priority]
  8858. let default_implementation gen native_array_cl =
  8859. let rec run e =
  8860. match e.eexpr with
  8861. | TArrayDecl el ->
  8862. let cl, params = match follow e.etype with
  8863. | TInst(({ cl_path = ([], "Array") } as cl), ( _ :: _ as params)) -> cl, params
  8864. | TInst(({ cl_path = ([], "Array") } as cl), []) -> cl, [t_dynamic]
  8865. | _ -> assert false
  8866. in
  8867. let changed_params = gen.greal_type_param (TClassDecl cl) params in
  8868. { e with eexpr = TNew(cl, changed_params, [ { e with eexpr = TArrayDecl(List.map run el); etype = TInst(native_array_cl, changed_params) } ] ); }
  8869. | _ -> Type.map_expr run e
  8870. in
  8871. run
  8872. let configure gen (mapping_func:texpr->texpr) =
  8873. let map e = Some(mapping_func e) in
  8874. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  8875. end;;
  8876. (* ******************************************* *)
  8877. (* SwitchBreakSynf *)
  8878. (* ******************************************* *)
  8879. (*
  8880. In most languages, 'break' is used as a statement also to break from switch statements.
  8881. This generates an incompatibility with haxe code, as we can use break to break from loops from inside a switch
  8882. This script will detect 'breaks' inside switch statements, and will offer the opportunity to change both
  8883. when this pattern is found.
  8884. Some options are possible:
  8885. On languages that support goto, 'break' may mean goto " after the loop ". There also can be special labels for
  8886. loops, so you can write "break label" (javascript, java, d)
  8887. On languages that do not support goto, a custom solution must be enforced
  8888. dependencies:
  8889. Since UnreachableCodeElimination must run before it, and Unreachable should be one of the
  8890. very last filters to run, we will make a fixed value which runs after UnreachableCodeElimination
  8891. (meaning: it's the very last filter)
  8892. *)
  8893. module SwitchBreakSynf =
  8894. struct
  8895. let name = "switch_break_synf"
  8896. let priority = min_dep -. 150.0
  8897. type add_to_block_api = texpr->bool->unit
  8898. let traverse gen (change_loop:texpr->int->add_to_block_api->texpr) (change_break:texpr->int->add_to_block_api->texpr) =
  8899. let in_switch = ref false in
  8900. let cur_block = ref [] in
  8901. let to_add = ref [] in
  8902. let did_found = ref (-1) in
  8903. let api expr before =
  8904. if before then cur_block := expr :: !cur_block else to_add := expr :: !to_add
  8905. in
  8906. let num = ref 0 in
  8907. let cur_num = ref 0 in
  8908. let rec run e =
  8909. match e.eexpr with
  8910. | TFunction _ ->
  8911. let old_num = !num in
  8912. num := 0;
  8913. let ret = Type.map_expr run e in
  8914. num := old_num;
  8915. ret
  8916. | TFor _
  8917. | TWhile _ ->
  8918. let last_switch = !in_switch in
  8919. let last_found = !did_found in
  8920. let last_num = !cur_num in
  8921. in_switch := false;
  8922. incr num;
  8923. cur_num := !num;
  8924. did_found := -1;
  8925. let new_e = Type.map_expr run e in (* assuming that no loop will be found in the condition *)
  8926. let new_e = if !did_found <> -1 then change_loop new_e !did_found api else new_e in
  8927. did_found := last_found;
  8928. in_switch := last_switch;
  8929. cur_num := last_num;
  8930. new_e
  8931. | TSwitch _ ->
  8932. let last_switch = !in_switch in
  8933. in_switch := true;
  8934. let new_e = Type.map_expr run e in
  8935. in_switch := last_switch;
  8936. new_e
  8937. | TBlock bl ->
  8938. let last_block = !cur_block in
  8939. let last_toadd = !to_add in
  8940. to_add := [];
  8941. cur_block := [];
  8942. List.iter (fun e ->
  8943. let new_e = run e in
  8944. cur_block := new_e :: !cur_block;
  8945. match !to_add with
  8946. | [] -> ()
  8947. | _ -> cur_block := !to_add @ !cur_block; to_add := []
  8948. ) bl;
  8949. let ret = List.rev !cur_block in
  8950. cur_block := last_block;
  8951. to_add := last_toadd;
  8952. { e with eexpr = TBlock(ret) }
  8953. | TBreak ->
  8954. if !in_switch then (did_found := !cur_num; change_break e !cur_num api) else e
  8955. | _ -> Type.map_expr run e
  8956. in
  8957. run
  8958. let configure gen (mapping_func:texpr->texpr) =
  8959. let map e = Some(mapping_func e) in
  8960. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  8961. end;;
  8962. (* ******************************************* *)
  8963. (* Unreachable Code Elimination *)
  8964. (* ******************************************* *)
  8965. (*
  8966. In some source code platforms, the code won't compile if there is Unreachable code, so this filter will take off any unreachable code.
  8967. If the parameter "handle_switch_break" is set to true, it will already add a "break" statement on switch cases when suitable;
  8968. in order to not confuse with while break, it will be a special expression __sbreak__
  8969. If the parameter "handle_not_final_returns" is set to true, it will also add final returns when functions are detected to be lacking of them.
  8970. (Will respect __fallback__ expressions)
  8971. If the parameter "java_mode" is set to true, some additional checks following the java unreachable specs
  8972. (http://docs.oracle.com/javase/specs/jls/se7/html/jls-14.html#jls-14.21) will be added
  8973. dependencies:
  8974. This must run before SwitchBreakSynf (see SwitchBreakSynf dependecy value)
  8975. This must be the LAST syntax filter to run. It expects ExpressionUnwrap to have run correctly, since this will only work for source-code based targets
  8976. *)
  8977. module UnreachableCodeEliminationSynf =
  8978. struct
  8979. let name = "unreachable_synf"
  8980. let priority = min_dep -. 100.0
  8981. type uexpr_kind =
  8982. | Normal
  8983. | BreaksLoop
  8984. | BreaksFunction
  8985. let aggregate_kind e1 e2 =
  8986. match e1, e2 with
  8987. | Normal, _
  8988. | _, Normal -> Normal
  8989. | BreaksLoop, _
  8990. | _, BreaksLoop -> BreaksLoop
  8991. | BreaksFunction, BreaksFunction -> BreaksFunction
  8992. let aggregate_constant op c1 c2=
  8993. match op, c1, c2 with
  8994. | OpEq, Some v1, Some v2 -> Some (TBool (v1 = v2))
  8995. | OpNotEq, Some v1, Some v2 -> Some (TBool (v1 <> v2))
  8996. | OpBoolOr, Some (TBool v1) , Some (TBool v2) -> Some (TBool (v1 || v2))
  8997. | OpBoolAnd, Some (TBool v1) , Some (TBool v2) -> Some (TBool (v1 && v2))
  8998. | OpAssign, _, Some v2 -> Some v2
  8999. | _ -> None
  9000. let rec get_constant_expr e =
  9001. match e.eexpr with
  9002. | TConst (v) -> Some v
  9003. | TBinop(op, v1, v2) -> aggregate_constant op (get_constant_expr v1) (get_constant_expr v2)
  9004. | TParenthesis(e) | TMeta(_,e) -> get_constant_expr e
  9005. | _ -> None
  9006. let traverse gen should_warn handle_switch_break handle_not_final_returns java_mode =
  9007. let basic = gen.gcon.basic in
  9008. let do_warn =
  9009. if should_warn then gen.gcon.warning "Unreachable code" else (fun pos -> ())
  9010. in
  9011. let return_loop expr kind =
  9012. match kind with
  9013. | Normal | BreaksLoop -> expr, Normal
  9014. | _ -> expr, kind
  9015. in
  9016. let sbreak = alloc_var "__sbreak__" t_dynamic in
  9017. let mk_sbreak = mk_local sbreak in
  9018. let rec has_fallback expr = match expr.eexpr with
  9019. | TBlock(bl) -> (match List.rev bl with
  9020. | { eexpr = TLocal { v_name = "__fallback__" } } :: _ -> true
  9021. | ({ eexpr = TBlock(_) } as bl) :: _ -> has_fallback bl
  9022. | _ -> false)
  9023. | TLocal { v_name = "__fallback__" } -> true
  9024. | _ -> false
  9025. in
  9026. let handle_case = if handle_switch_break then
  9027. (fun (expr,kind) ->
  9028. match kind with
  9029. | Normal when has_fallback expr -> expr
  9030. | Normal -> Type.concat expr (mk_sbreak expr.epos)
  9031. | BreaksLoop | BreaksFunction -> expr
  9032. )
  9033. else
  9034. fst
  9035. in
  9036. let has_break = ref false in
  9037. let rec process_expr expr =
  9038. match expr.eexpr with
  9039. | TReturn _ | TThrow _ -> expr, BreaksFunction
  9040. | TContinue -> expr, BreaksLoop
  9041. | TBreak -> has_break := true; expr, BreaksLoop
  9042. | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> expr, BreaksLoop
  9043. | TBlock bl ->
  9044. let new_block = ref [] in
  9045. let is_unreachable = ref false in
  9046. let ret_kind = ref Normal in
  9047. List.iter (fun e ->
  9048. if !is_unreachable then
  9049. do_warn e.epos
  9050. else begin
  9051. let changed_e, kind = process_expr e in
  9052. new_block := changed_e :: !new_block;
  9053. match kind with
  9054. | BreaksLoop | BreaksFunction ->
  9055. ret_kind := kind;
  9056. is_unreachable := true
  9057. | _ -> ()
  9058. end
  9059. ) bl;
  9060. { expr with eexpr = TBlock(List.rev !new_block) }, !ret_kind
  9061. | TFunction tf ->
  9062. let changed, kind = process_expr tf.tf_expr in
  9063. let changed = if handle_not_final_returns && not (is_void tf.tf_type) && kind <> BreaksFunction then
  9064. Type.concat changed { eexpr = TReturn( Some (null tf.tf_type expr.epos) ); etype = basic.tvoid; epos = expr.epos }
  9065. else
  9066. changed
  9067. in
  9068. { expr with eexpr = TFunction({ tf with tf_expr = changed }) }, Normal
  9069. | TFor(var, cond, block) ->
  9070. let last_has_break = !has_break in
  9071. has_break := false;
  9072. let changed_block, _ = process_expr block in
  9073. has_break := last_has_break;
  9074. let expr = { expr with eexpr = TFor(var, cond, changed_block) } in
  9075. return_loop expr Normal
  9076. | TIf(cond, eif, None) ->
  9077. if java_mode then
  9078. match get_constant_expr cond with
  9079. | Some (TBool true) ->
  9080. process_expr eif
  9081. | _ ->
  9082. { expr with eexpr = TIf(cond, fst (process_expr eif), None) }, Normal
  9083. else
  9084. { expr with eexpr = TIf(cond, fst (process_expr eif), None) }, Normal
  9085. | TIf(cond, eif, Some eelse) ->
  9086. let eif, eif_k = process_expr eif in
  9087. let eelse, eelse_k = process_expr eelse in
  9088. let k = aggregate_kind eif_k eelse_k in
  9089. { expr with eexpr = TIf(cond, eif, Some eelse) }, k
  9090. | TWhile(cond, block, flag) ->
  9091. let last_has_break = !has_break in
  9092. has_break := false;
  9093. let block, k = process_expr block in
  9094. if java_mode then
  9095. match get_constant_expr cond, flag, !has_break with
  9096. | Some (TBool true), _, false ->
  9097. has_break := last_has_break;
  9098. { expr with eexpr = TWhile(cond, block, flag) }, BreaksFunction
  9099. | Some (TBool false), NormalWhile, _ ->
  9100. has_break := last_has_break;
  9101. do_warn expr.epos;
  9102. null expr.etype expr.epos, Normal
  9103. | _ ->
  9104. has_break := last_has_break;
  9105. return_loop { expr with eexpr = TWhile(cond,block,flag) } Normal
  9106. else begin
  9107. has_break := last_has_break;
  9108. return_loop { expr with eexpr = TWhile(cond,block,flag) } Normal
  9109. end
  9110. | TSwitch(cond, el_e_l, None) ->
  9111. { expr with eexpr = TSwitch(cond, List.map (fun (el, e) -> (el, handle_case (process_expr e))) el_e_l, None) }, Normal
  9112. | TSwitch(cond, el_e_l, Some def) ->
  9113. let def, k = process_expr def in
  9114. let def = handle_case (def, k) in
  9115. let k = ref k in
  9116. let ret = { expr with eexpr = TSwitch(cond, List.map (fun (el, e) ->
  9117. let e, ek = process_expr e in
  9118. k := aggregate_kind !k ek;
  9119. (el, handle_case (e, ek))
  9120. ) el_e_l, Some def) } in
  9121. ret, !k
  9122. (* | TMatch(cond, ep, il_vopt_e_l, None) ->
  9123. { expr with eexpr = TMatch(cond, ep, List.map (fun (il, vopt, e) -> (il, vopt, handle_case (process_expr e))) il_vopt_e_l, None) }, Normal *)
  9124. (* | TMatch(cond, ep, il_vopt_e_l, Some def) ->
  9125. let def, k = process_expr def in
  9126. let def = handle_case (def, k) in
  9127. let k = ref k in
  9128. let ret = { expr with eexpr = TMatch(cond, ep, List.map (fun (il, vopt, e) ->
  9129. let e, ek = process_expr e in
  9130. k := aggregate_kind !k ek;
  9131. (il, vopt, handle_case (e, ek))
  9132. ) il_vopt_e_l, Some def) } in
  9133. ret, !k *)
  9134. | TTry (e, catches) ->
  9135. let e, k = process_expr e in
  9136. let k = ref k in
  9137. let ret = { expr with eexpr = TTry(e, List.map (fun (v, e) ->
  9138. let e, ek = process_expr e in
  9139. k := aggregate_kind !k ek;
  9140. (v, e)
  9141. ) catches) } in
  9142. ret, !k
  9143. | _ -> expr, Normal
  9144. in
  9145. let run e = fst (process_expr e) in
  9146. run
  9147. let configure gen (mapping_func:texpr->texpr) =
  9148. let map e = Some(mapping_func e) in
  9149. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  9150. end;;
  9151. (* ******************************************* *)
  9152. (* DefaultArguments *)
  9153. (* ******************************************* *)
  9154. (*
  9155. This Module Filter will go through all defined functions in all modules and change them
  9156. so they set all default arguments to be of a Nullable type, and adds the unroll from nullable to
  9157. the not-nullable type in the beginning of the function.
  9158. dependencies:
  9159. It must run before OverloadingCtors, since OverloadingCtors will change optional structures behavior
  9160. *)
  9161. module DefaultArguments =
  9162. struct
  9163. let name = "default_arguments"
  9164. let priority = solve_deps name [ DBefore OverloadingConstructor.priority ]
  9165. let gen_check basic t nullable_var const pos =
  9166. let is_null t = match t with TType({t_path = ([],"Null")}, _) -> true | _ -> false in
  9167. let needs_cast t1 t2 = match is_null t1, is_null t2 with
  9168. | true, false | false, true -> true
  9169. | _ -> false
  9170. in
  9171. let const_t = match const with
  9172. | TString _ -> basic.tstring | TInt _ -> basic.tint | TFloat _ -> basic.tfloat
  9173. | TNull -> t | TBool _ -> basic.tbool | _ -> assert false
  9174. in
  9175. let const = { eexpr = TConst(const); etype = const_t; epos = pos } in
  9176. let const = if needs_cast t const_t then mk_cast t const else const in
  9177. let arg = mk_local nullable_var pos in
  9178. let arg = if needs_cast t nullable_var.v_type then mk_cast t arg else arg in
  9179. {
  9180. eexpr = TIf(
  9181. { eexpr = TBinop(Ast.OpEq, mk_local nullable_var pos, null nullable_var.v_type pos); etype = basic.tbool; epos = pos },
  9182. const,
  9183. Some(arg)
  9184. );
  9185. etype = t;
  9186. epos = pos;
  9187. }
  9188. let add_opt gen block pos (var,opt) =
  9189. match opt with
  9190. | None | Some TNull -> (var,opt)
  9191. | Some (TString str) ->
  9192. block := Codegen.set_default gen.gcon var (TString str) pos :: !block;
  9193. (var, opt)
  9194. | Some const ->
  9195. let basic = gen.gcon.basic in
  9196. let nullable_var = mk_temp gen var.v_name (basic.tnull var.v_type) in
  9197. let orig_name = var.v_name in
  9198. var.v_name <- nullable_var.v_name;
  9199. nullable_var.v_name <- orig_name;
  9200. (* var v = (temp_var == null) ? const : cast temp_var; *)
  9201. block :=
  9202. {
  9203. eexpr = TVar(var, Some(gen_check basic var.v_type nullable_var const pos));
  9204. etype = basic.tvoid;
  9205. epos = pos;
  9206. } :: !block;
  9207. (nullable_var, opt)
  9208. let rec change_func gen cf =
  9209. List.iter (change_func gen) cf.cf_overloads;
  9210. let is_ctor = cf.cf_name = "new" in
  9211. let basic = gen.gcon.basic in
  9212. match cf.cf_kind, follow cf.cf_type with
  9213. | Var _, _ | Method MethDynamic, _ -> ()
  9214. | _, TFun(args, ret) ->
  9215. let found = ref false in
  9216. let args = ref (List.map (fun (n,opt,t) ->
  9217. (n,opt, if opt then (found := true; basic.tnull t) else t)
  9218. ) args) in
  9219. (match !found, cf.cf_expr with
  9220. | true, Some ({ eexpr = TFunction tf } as texpr) ->
  9221. let block = ref [] in
  9222. let tf_args = List.map (add_opt gen block tf.tf_expr.epos) tf.tf_args in
  9223. let arg_assoc = List.map2 (fun (v,o) (v2,_) -> v,(v2,o) ) tf.tf_args tf_args in
  9224. let rec extract_super e = match e.eexpr with
  9225. | TBlock(({ eexpr = TCall({ eexpr = TConst TSuper }, _) } as e2) :: tl) ->
  9226. e2, tl
  9227. | TBlock(hd :: tl) ->
  9228. let e2, tl2 = extract_super hd in
  9229. e2, tl2 @ tl
  9230. | _ -> raise Not_found
  9231. in
  9232. let block = try
  9233. if not is_ctor then raise Not_found;
  9234. (* issue #2570 *)
  9235. (* check if the class really needs the super as the first statement -
  9236. just to make sure we don't inadvertently break any existing code *)
  9237. let rec check cl =
  9238. if not (is_hxgen (TClassDecl cl)) then
  9239. ()
  9240. else match cl.cl_super with
  9241. | None ->
  9242. raise Not_found
  9243. | Some (cl,_) ->
  9244. check cl
  9245. in
  9246. (match gen.gcurrent_class with
  9247. | Some cl -> check cl
  9248. | _ -> ());
  9249. let super, tl = extract_super tf.tf_expr in
  9250. (match super.eexpr with
  9251. | TCall({ eexpr = TConst TSuper } as e1, args) ->
  9252. (* any super argument will be replaced by an inlined version of the check *)
  9253. let found = ref false in
  9254. let rec replace_args e = match e.eexpr with
  9255. | TLocal(v) -> (try
  9256. let v2,o = List.assq v arg_assoc in
  9257. let o = match o with
  9258. | None -> raise Not_found
  9259. | Some o -> o
  9260. in
  9261. found := true;
  9262. gen_check gen.gcon.basic v.v_type v2 o e.epos
  9263. with | Not_found -> e)
  9264. | _ -> Type.map_expr replace_args e
  9265. in
  9266. let args = List.map (replace_args) args in
  9267. { tf.tf_expr with eexpr = TBlock((if !found then { super with eexpr = TCall(e1,args) } else super) :: !block @ tl) }
  9268. | _ -> assert false)
  9269. with | Not_found ->
  9270. Type.concat { tf.tf_expr with eexpr = TBlock(!block); etype = basic.tvoid } tf.tf_expr
  9271. in
  9272. args := fun_args tf_args;
  9273. cf.cf_expr <- Some( {texpr with eexpr = TFunction( { tf with
  9274. tf_args = tf_args;
  9275. tf_expr = block
  9276. } ); etype = TFun(!args, ret) } );
  9277. cf.cf_type <- TFun(!args, ret)
  9278. | _ -> ()
  9279. );
  9280. (if !found then cf.cf_type <- TFun(!args, ret))
  9281. | _, _ -> assert false
  9282. let traverse gen =
  9283. let run md = match md with
  9284. | TClassDecl cl ->
  9285. List.iter (change_func gen) cl.cl_ordered_fields;
  9286. List.iter (change_func gen) cl.cl_ordered_statics;
  9287. (match cl.cl_constructor with | None -> () | Some cf -> change_func gen cf);
  9288. md
  9289. | _ -> md
  9290. in
  9291. run
  9292. let configure gen (mapping_func:module_type->module_type) =
  9293. let map md = Some(mapping_func md) in
  9294. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9295. end;;
  9296. (* ******************************************* *)
  9297. (* Interface Variables Removal Modf *)
  9298. (* ******************************************* *)
  9299. (*
  9300. This module filter will take care of sanitizing interfaces for targets that do not support
  9301. variables declaration in interfaces. By now this will mean that if anything is typed as the interface,
  9302. and a variable access is made, a FNotFound will be returned for the field_access, so
  9303. the field will be only accessible by reflection.
  9304. Speed-wise, ideally it would be best to create getProp/setProp functions in this case and change
  9305. the AST to call them when accessing by interface. (TODO)
  9306. But right now it will be accessed by reflection.
  9307. dependencies:
  9308. *)
  9309. module InterfaceVarsDeleteModf =
  9310. struct
  9311. let name = "interface_vars"
  9312. let priority = solve_deps name []
  9313. let run gen =
  9314. let run md = match md with
  9315. | TClassDecl ( { cl_interface = true } as cl ) ->
  9316. let to_add = ref [] in
  9317. let fields = List.filter (fun cf ->
  9318. match cf.cf_kind with
  9319. | Var _ when gen.gcon.platform = Cs && Meta.has Meta.Event cf.cf_meta ->
  9320. true
  9321. | Var vkind when not (Type.is_extern_field cf && Meta.has Meta.Property cf.cf_meta) ->
  9322. (match vkind.v_read with
  9323. | AccCall ->
  9324. let newcf = mk_class_field ("get_" ^ cf.cf_name) (TFun([],cf.cf_type)) true cf.cf_pos (Method MethNormal) [] in
  9325. to_add := newcf :: !to_add;
  9326. | _ -> ()
  9327. );
  9328. (match vkind.v_write with
  9329. | AccCall ->
  9330. let newcf = mk_class_field ("set_" ^ cf.cf_name) (TFun(["val",false,cf.cf_type],cf.cf_type)) true cf.cf_pos (Method MethNormal) [] in
  9331. to_add := newcf :: !to_add;
  9332. | _ -> ()
  9333. );
  9334. cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields;
  9335. false
  9336. | Method MethDynamic ->
  9337. (* TODO OPTIMIZATION - add a `_dispatch` method to the interface which will call the dynamic function itself *)
  9338. cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields;
  9339. false
  9340. | _ -> true
  9341. ) cl.cl_ordered_fields in
  9342. cl.cl_ordered_fields <- fields;
  9343. List.iter (fun cf ->
  9344. match field_access gen (TInst(cl,List.map snd cl.cl_params)) cf.cf_name with
  9345. | FNotFound | FDynamicField _ ->
  9346. cl.cl_ordered_fields <- cf :: cl.cl_ordered_fields;
  9347. cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields
  9348. | _ -> ()
  9349. ) !to_add;
  9350. md
  9351. | _ -> md
  9352. in
  9353. run
  9354. let configure gen =
  9355. let run = run gen in
  9356. let map md = Some(run md) in
  9357. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9358. end;;
  9359. (* ******************************************* *)
  9360. (* InterfaceProps *)
  9361. (* ******************************************* *)
  9362. (*
  9363. This module filter will go through all declared properties, and see if they are conforming to a native interface.
  9364. If they are, it will add Meta.Property to it
  9365. dependencies:
  9366. *)
  9367. module InterfaceProps =
  9368. struct
  9369. let name = "interface_props"
  9370. let priority = solve_deps name []
  9371. let run gen =
  9372. let run md = match md with
  9373. | TClassDecl ( { cl_interface = false; cl_extern = false } as cl ) ->
  9374. let vars = List.fold_left (fun acc (iface,_) ->
  9375. if Meta.has Meta.CsNative iface.cl_meta then
  9376. List.filter (fun cf -> match cf.cf_kind with
  9377. | Var { v_read = AccCall } | Var { v_write = AccCall } ->
  9378. true
  9379. | _ -> false
  9380. ) iface.cl_ordered_fields @ acc
  9381. else
  9382. acc
  9383. ) [] cl.cl_implements in
  9384. let vars = List.map (fun cf -> cf.cf_name) vars in
  9385. if vars <> [] then
  9386. List.iter (fun cf -> match cf.cf_kind with
  9387. | Var { v_read = AccCall } | Var { v_write = AccCall } when List.mem cf.cf_name vars ->
  9388. cf.cf_meta <- (Meta.Property, [], Ast.null_pos) :: cf.cf_meta
  9389. | _ -> ()
  9390. ) cl.cl_ordered_fields;
  9391. md
  9392. | _ -> md
  9393. in
  9394. run
  9395. let configure gen =
  9396. let run = run gen in
  9397. let map md = Some(run md) in
  9398. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9399. end;;
  9400. (* ******************************************* *)
  9401. (* Int Division Synf *)
  9402. (* ******************************************* *)
  9403. (*
  9404. On targets that support int division, this module will force a float division to be performed,
  9405. so compatibility with current haxe targets is ensured.
  9406. If catch_int_div is set to true, though, it will look for casts to int or use of Std.int() to optimize
  9407. this kind of operation.
  9408. dependencies:
  9409. since it depends on nothing, but many modules might generate division expressions,
  9410. it will be one of the last modules to run
  9411. *)
  9412. module IntDivisionSynf =
  9413. struct
  9414. let name = "int_division_synf"
  9415. let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority ]
  9416. let is_int = like_int
  9417. let is_exactly_int t = match follow t with
  9418. | TAbstract ({ a_path=[],"Int" }, []) -> true
  9419. | _ -> false
  9420. let default_implementation gen catch_int_div =
  9421. let basic = gen.gcon.basic in
  9422. let rec run e =
  9423. match e.eexpr with
  9424. | TBinop((Ast.OpDiv as op), e1, e2) when is_int e1.etype && is_int e2.etype ->
  9425. { e with eexpr = TBinop(op, mk_cast basic.tfloat (run e1), run e2) }
  9426. | TCall(
  9427. { eexpr = TField(_, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" })) },
  9428. [ ({ eexpr = TBinop((Ast.OpDiv as op), e1, e2) } as ebinop ) ]
  9429. ) when catch_int_div && is_int e1.etype && is_int e2.etype ->
  9430. let e = { ebinop with eexpr = TBinop(op, run e1, run e2); etype = basic.tint } in
  9431. if not (is_exactly_int e1.etype && is_exactly_int e2.etype) then
  9432. mk_cast basic.tint e
  9433. else
  9434. e
  9435. | TCast( ({ eexpr = TBinop((Ast.OpDiv as op), e1, e2) } as ebinop ), _ )
  9436. | TCast( ({ eexpr = TBinop(( (Ast.OpAssignOp Ast.OpDiv) as op), e1, e2) } as ebinop ), _ ) when catch_int_div && is_int e1.etype && is_int e2.etype && is_int e.etype ->
  9437. let ret = { ebinop with eexpr = TBinop(op, run e1, run e2); etype = e.etype } in
  9438. if not (is_exactly_int e1.etype && is_exactly_int e2.etype) then
  9439. mk_cast e.etype ret
  9440. else
  9441. e
  9442. | _ -> Type.map_expr run e
  9443. in
  9444. run
  9445. let configure gen (mapping_func:texpr->texpr) =
  9446. let map e = Some(mapping_func e) in
  9447. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  9448. end;;
  9449. (* ******************************************* *)
  9450. (* UnnecessaryCastsRemoval *)
  9451. (* ******************************************* *)
  9452. (*
  9453. This module will take care of simplifying unnecessary casts, specially those made by the compiler
  9454. when inlining. Right now, it will only take care of casts used as a statement, which are always useless;
  9455. TODO: Take care of more cases, e.g. when the to and from types are the same
  9456. dependencies:
  9457. This must run after CastDetection, but before ExpressionUnwrap
  9458. *)
  9459. module UnnecessaryCastsRemoval =
  9460. struct
  9461. let name = "casts_removal"
  9462. let priority = solve_deps name [DAfter CastDetect.priority; DBefore ExpressionUnwrap.priority]
  9463. let rec take_off_cast run e =
  9464. match e.eexpr with
  9465. | TCast (c, _) ->
  9466. take_off_cast run c
  9467. | _ -> run e
  9468. let default_implementation gen =
  9469. let rec traverse e =
  9470. match e.eexpr with
  9471. | TBlock bl ->
  9472. let bl = List.map (fun e ->
  9473. take_off_cast traverse e
  9474. ) bl in
  9475. { e with eexpr = TBlock bl }
  9476. | TTry (block, catches) ->
  9477. { e with eexpr = TTry(traverse (mk_block block), List.map (fun (v,block) -> (v, traverse (mk_block block))) catches) }
  9478. (* | TMatch (cond,ep,il_vol_e_l,default) ->
  9479. { e with eexpr = TMatch(cond,ep,List.map (fun (il,vol,e) -> (il,vol,traverse (mk_block e))) il_vol_e_l, Option.map (fun e -> traverse (mk_block e)) default) } *)
  9480. | TSwitch (cond,el_e_l, default) ->
  9481. { e with eexpr = TSwitch(cond, List.map (fun (el,e) -> (el, traverse (mk_block e))) el_e_l, Option.map (fun e -> traverse (mk_block e)) default) }
  9482. | TWhile (cond,block,flag) ->
  9483. {e with eexpr = TWhile(cond,traverse (mk_block block), flag) }
  9484. | TIf (cond, eif, eelse) ->
  9485. { e with eexpr = TIf(cond, traverse (mk_block eif), Option.map (fun e -> traverse (mk_block e)) eelse) }
  9486. | TFor (v,it,block) ->
  9487. { e with eexpr = TFor(v,it, traverse (mk_block block)) }
  9488. | TFunction (tfunc) ->
  9489. { e with eexpr = TFunction({ tfunc with tf_expr = traverse (mk_block tfunc.tf_expr) }) }
  9490. | _ -> e (* if expression doesn't have a block, we will exit *)
  9491. in
  9492. traverse
  9493. let configure gen =
  9494. let map e = Some(default_implementation gen e) in
  9495. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  9496. end;;
  9497. (* ******************************************* *)
  9498. (* OverrideFix *)
  9499. (* ******************************************* *)
  9500. (*
  9501. When DCE is on, sometimes a field is marked as override when it
  9502. really doesn't override anything. This module filter will take care of this.
  9503. dependencies:
  9504. No dependencies
  9505. *)
  9506. module OverrideFix =
  9507. struct
  9508. let name = "override_fix"
  9509. let priority = solve_deps name []
  9510. let default_implementation gen =
  9511. let rec run e =
  9512. match e.eexpr with
  9513. | _ -> Type.map_expr run e
  9514. in
  9515. run
  9516. let configure gen =
  9517. let map md =
  9518. match md with
  9519. | TClassDecl cl ->
  9520. cl.cl_overrides <- List.filter (fun s ->
  9521. let rec loop cl =
  9522. match cl.cl_super with
  9523. | Some (cl,_) when PMap.mem s.cf_name cl.cl_fields -> true
  9524. | Some (cl,_) -> loop cl
  9525. | None -> false
  9526. in
  9527. loop cl
  9528. ) cl.cl_overrides;
  9529. Some md
  9530. | _ -> Some md
  9531. in
  9532. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9533. end;;
  9534. (* ******************************************* *)
  9535. (* AbstractImplementationFix *)
  9536. (* ******************************************* *)
  9537. (*
  9538. This module filter will map the compiler created classes from abstract
  9539. implementations to valid haxe code, as needed by gencommon
  9540. dependencies:
  9541. No dependencies
  9542. *)
  9543. module AbstractImplementationFix =
  9544. struct
  9545. let name = "abstract_implementation_fix"
  9546. let priority = solve_deps name []
  9547. let default_implementation gen =
  9548. let rec run md =
  9549. match md with
  9550. | TClassDecl ({ cl_kind = KAbstractImpl a } as c) ->
  9551. List.iter (function
  9552. | ({ cf_name = "_new" } as cf) ->
  9553. cf.cf_params <- cf.cf_params @ a.a_params
  9554. | cf when Meta.has Meta.Impl cf.cf_meta ->
  9555. (match cf.cf_expr with
  9556. | Some({ eexpr = TFunction({ tf_args = (v, _) :: _ }) }) when Meta.has Meta.This v.v_meta ->
  9557. cf.cf_params <- cf.cf_params @ a.a_params
  9558. | _ -> ())
  9559. | _ -> ()
  9560. ) c.cl_ordered_statics;
  9561. Some md
  9562. | _ -> Some md
  9563. in
  9564. run
  9565. let configure gen =
  9566. let map = default_implementation gen in
  9567. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9568. end;;
  9569. (* ******************************************* *)
  9570. (* FixOverrides *)
  9571. (* ******************************************* *)
  9572. (*
  9573. Covariant return types, contravariant function arguments and applied type parameters may change
  9574. in a way that expected implementations / overrides aren't recognized as such.
  9575. This filter will fix that.
  9576. dependencies:
  9577. FixOverrides expects that the target platform is able to deal with overloaded functions
  9578. It must run after DefaultArguments, otherwise code added by the default arguments may be invalid
  9579. *)
  9580. module FixOverrides =
  9581. struct
  9582. let name = "fix_overrides"
  9583. let priority = solve_deps name [DAfter DefaultArguments.priority]
  9584. (*
  9585. if the platform allows explicit interface implementation (C#),
  9586. specify a explicit_fn_name function (tclass->string->string)
  9587. Otherwise, it expects the platform to be able to handle covariant return types
  9588. *)
  9589. let run ~explicit_fn_name ~get_vmtype gen =
  9590. let implement_explicitly = is_some explicit_fn_name in
  9591. let run md = match md with
  9592. | TClassDecl ( { cl_interface = true; cl_extern = false } as c ) ->
  9593. (* overrides can be removed from interfaces *)
  9594. c.cl_ordered_fields <- List.filter (fun f ->
  9595. try
  9596. if Meta.has Meta.Overload f.cf_meta then raise Not_found;
  9597. let f2 = Codegen.find_field gen.gcon c f in
  9598. if f2 == f then raise Not_found;
  9599. c.cl_fields <- PMap.remove f.cf_name c.cl_fields;
  9600. false;
  9601. with Not_found ->
  9602. true
  9603. ) c.cl_ordered_fields;
  9604. md
  9605. | TClassDecl({ cl_extern = false } as c) ->
  9606. let this = { eexpr = TConst TThis; etype = TInst(c,List.map snd c.cl_params); epos = c.cl_pos } in
  9607. (* look through all interfaces, and try to find a type that applies exactly *)
  9608. let rec loop_iface (iface:tclass) itl =
  9609. List.iter (fun (s,stl) -> loop_iface s (List.map (apply_params iface.cl_params itl) stl)) iface.cl_implements;
  9610. let real_itl = gen.greal_type_param (TClassDecl iface) itl in
  9611. let rec loop_f f =
  9612. List.iter loop_f f.cf_overloads;
  9613. let ftype = apply_params iface.cl_params itl f.cf_type in
  9614. let real_ftype = get_real_fun gen (apply_params iface.cl_params real_itl f.cf_type) in
  9615. replace_mono real_ftype;
  9616. let overloads = Typeload.get_overloads c f.cf_name in
  9617. try
  9618. let t2, f2 =
  9619. match overloads with
  9620. | (_, cf) :: _ when Meta.has Meta.Overload cf.cf_meta -> (* overloaded function *)
  9621. (* try to find exact function *)
  9622. List.find (fun (t,f2) ->
  9623. Typeload.same_overload_args ~get_vmtype ftype t f f2
  9624. ) overloads
  9625. | _ :: _ ->
  9626. (match field_access gen (TInst(c, List.map snd c.cl_params)) f.cf_name with
  9627. | FClassField(_,_,_,f2,false,t,_) -> t,f2 (* if it's not an overload, all functions should have the same signature *)
  9628. | _ -> raise Not_found)
  9629. | [] -> raise Not_found
  9630. in
  9631. replace_mono t2;
  9632. (* if we find a function with the exact type of real_ftype, it means this interface has already been taken care of *)
  9633. if not (type_iseq (get_real_fun gen (apply_params f2.cf_params (List.map snd f.cf_params) t2)) real_ftype) then begin
  9634. (match f.cf_kind with | Method (MethNormal | MethInline) -> () | _ -> raise Not_found);
  9635. let t2 = get_real_fun gen t2 in
  9636. if List.length f.cf_params <> List.length f2.cf_params then raise Not_found;
  9637. replace_mono t2;
  9638. match follow (apply_params f2.cf_params (List.map snd f.cf_params) t2), follow real_ftype with
  9639. | TFun(a1,r1), TFun(a2,r2) when not implement_explicitly && not (type_iseq r1 r2) && Typeload.same_overload_args ~get_vmtype real_ftype t2 f f2 ->
  9640. (* different return types are the trickiest cases to deal with *)
  9641. (* check for covariant return type *)
  9642. let is_covariant = match follow r1, follow r2 with
  9643. | _, TDynamic _ -> true
  9644. | r1, r2 -> try
  9645. unify r1 r2;
  9646. true
  9647. with | Unify_error _ -> false
  9648. in
  9649. (* we only have to worry about non-covariant issues *)
  9650. if not is_covariant then begin
  9651. (* override return type and cast implemented function *)
  9652. let args, newr = match follow t2, follow (apply_params f.cf_params (List.map snd f2.cf_params) real_ftype) with
  9653. | TFun(a,_), TFun(_,r) -> a,r
  9654. | _ -> assert false
  9655. in
  9656. f2.cf_type <- TFun(args,newr);
  9657. (match f2.cf_expr with
  9658. | Some ({ eexpr = TFunction tf } as e) ->
  9659. f2.cf_expr <- Some { e with eexpr = TFunction { tf with tf_type = newr } }
  9660. | _ -> ())
  9661. end
  9662. | TFun(a1,r1), TFun(a2,r2) ->
  9663. (* just implement a function that will call the main one *)
  9664. let name, is_explicit = match explicit_fn_name with
  9665. | Some fn when not (type_iseq r1 r2) && Typeload.same_overload_args ~get_vmtype real_ftype t2 f f2 ->
  9666. fn iface itl f.cf_name, true
  9667. | _ -> f.cf_name, false
  9668. in
  9669. let p = f2.cf_pos in
  9670. let newf = mk_class_field name real_ftype true f.cf_pos (Method MethNormal) f.cf_params in
  9671. let vars = List.map (fun (n,_,t) -> alloc_var n t) a2 in
  9672. let args = List.map2 (fun v (_,_,t) -> mk_cast t (mk_local v f2.cf_pos)) vars a1 in
  9673. let field = { eexpr = TField(this, FInstance(c,List.map snd c.cl_params,f2)); etype = TFun(a1,r1); epos = p } in
  9674. let call = { eexpr = TCall(field, args); etype = r1; epos = p } in
  9675. (* let call = gen.gparam_func_call call field (List.map snd f.cf_params) args in *)
  9676. let is_void = is_void r2 in
  9677. newf.cf_expr <- Some {
  9678. eexpr = TFunction({
  9679. tf_args = List.map (fun v -> v,None) vars;
  9680. tf_type = r2;
  9681. tf_expr = (if is_void then call else {
  9682. eexpr = TReturn (Some (mk_cast r2 call));
  9683. etype = r2;
  9684. epos = p
  9685. })
  9686. });
  9687. etype = real_ftype;
  9688. epos = p;
  9689. };
  9690. (try
  9691. let fm = PMap.find name c.cl_fields in
  9692. fm.cf_overloads <- newf :: fm.cf_overloads
  9693. with | Not_found ->
  9694. c.cl_fields <- PMap.add name newf c.cl_fields;
  9695. c.cl_ordered_fields <- newf :: c.cl_ordered_fields)
  9696. | _ -> assert false
  9697. end
  9698. with | Not_found -> ()
  9699. in
  9700. List.iter (fun f -> match f.cf_kind with | Var _ -> () | _ -> loop_f f) iface.cl_ordered_fields
  9701. in
  9702. List.iter (fun (iface,itl) -> loop_iface iface itl) c.cl_implements;
  9703. (* now go through all overrides, *)
  9704. let rec check_f f =
  9705. (* find the first declared field *)
  9706. let is_overload = Meta.has Meta.Overload f.cf_meta in
  9707. let decl = if is_overload then
  9708. find_first_declared_field gen c ~get_vmtype ~exact_field:f f.cf_name
  9709. else
  9710. find_first_declared_field gen c ~get_vmtype f.cf_name
  9711. in
  9712. match decl with
  9713. | Some(f2,actual_t,_,t,declared_cl,_,_)
  9714. when not (Typeload.same_overload_args ~get_vmtype actual_t (get_real_fun gen f.cf_type) f2 f) ->
  9715. if Meta.has Meta.Overload f.cf_meta then begin
  9716. (* if it is overload, create another field with the requested type *)
  9717. let f3 = mk_class_field f.cf_name t f.cf_public f.cf_pos f.cf_kind f.cf_params in
  9718. let p = f.cf_pos in
  9719. let old_args, old_ret = get_fun f.cf_type in
  9720. let args, ret = get_fun t in
  9721. let tf_args = List.map (fun (n,o,t) -> alloc_var n t, None) args in
  9722. let f3_mk_return = if is_void ret then (fun e -> e) else (fun e -> mk_return (mk_cast ret e)) in
  9723. f3.cf_expr <- Some {
  9724. eexpr = TFunction({
  9725. tf_args = tf_args;
  9726. tf_type = ret;
  9727. tf_expr = mk_block (f3_mk_return {
  9728. eexpr = TCall(
  9729. {
  9730. eexpr = TField(
  9731. { eexpr = TConst TThis; etype = TInst(c, List.map snd c.cl_params); epos = p },
  9732. FInstance(c,List.map snd c.cl_params,f));
  9733. etype = f.cf_type;
  9734. epos = p
  9735. },
  9736. List.map2 (fun (v,_) (_,_,t) -> mk_cast t (mk_local v p)) tf_args old_args);
  9737. etype = old_ret;
  9738. epos = p
  9739. })
  9740. });
  9741. etype = t;
  9742. epos = p;
  9743. };
  9744. gen.gafter_filters_ended <- ((fun () ->
  9745. f.cf_overloads <- f3 :: f.cf_overloads;
  9746. ) :: gen.gafter_filters_ended);
  9747. f3
  9748. end else begin match f.cf_expr with
  9749. | Some({ eexpr = TFunction(tf) } as e) ->
  9750. (* if it's not overload, just cast the vars *)
  9751. let actual_args, _ = get_fun (get_real_fun gen actual_t) in
  9752. let new_args, vardecl = List.fold_left2 (fun (args,vdecl) (v,_) (_,_,t) ->
  9753. if not (type_iseq (gen.greal_type v.v_type) (gen.greal_type t)) then begin
  9754. let new_var = mk_temp gen v.v_name t in
  9755. (new_var,None) :: args, (v, Some(mk_cast v.v_type (mk_local new_var f.cf_pos))) :: vdecl
  9756. end else
  9757. (v,None) :: args, vdecl
  9758. ) ([],[]) tf.tf_args actual_args in
  9759. if vardecl <> [] then
  9760. f.cf_expr <- Some({ e with
  9761. eexpr = TFunction({ tf with
  9762. tf_args = List.rev new_args;
  9763. tf_expr = Type.concat { eexpr = TBlock(List.map (fun (v,ve) -> { eexpr = TVar(v,ve); etype = gen.gcon.basic.tvoid; epos = e.epos }) vardecl); etype = gen.gcon.basic.tvoid; epos = e.epos } tf.tf_expr
  9764. });
  9765. });
  9766. f
  9767. | _ -> f
  9768. end
  9769. | _ -> f
  9770. in
  9771. if not c.cl_extern then
  9772. c.cl_overrides <- List.map (fun f -> check_f f) c.cl_overrides;
  9773. md
  9774. | _ -> md
  9775. in
  9776. run
  9777. let configure ?explicit_fn_name ~get_vmtype gen =
  9778. let delay () =
  9779. Hashtbl.clear gen.greal_field_types
  9780. in
  9781. gen.gafter_mod_filters_ended <- delay :: gen.gafter_mod_filters_ended;
  9782. let run = run ~explicit_fn_name ~get_vmtype gen in
  9783. let map md = Some(run md) in
  9784. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9785. end;;
  9786. (* ******************************************* *)
  9787. (* Normalize *)
  9788. (* ******************************************* *)
  9789. (*
  9790. - Filters out enum constructor type parameters from the AST; See Issue #1796
  9791. - Filters out monomorphs
  9792. - Filters out all non-whitelisted AST metadata
  9793. dependencies:
  9794. No dependencies; but it still should be one of the first filters to run,
  9795. as it will help normalize the AST
  9796. *)
  9797. module Normalize =
  9798. struct
  9799. let name = "normalize_type"
  9800. let priority = max_dep
  9801. let rec filter_param t = match t with
  9802. | TInst({ cl_kind = KTypeParameter _ } as c,_) when Meta.has Meta.EnumConstructorParam c.cl_meta ->
  9803. t_dynamic
  9804. | TMono r -> (match !r with
  9805. | None -> t_dynamic
  9806. | Some t -> filter_param t)
  9807. | TInst(_,[]) | TEnum(_,[]) | TType(_,[]) | TAbstract(_,[]) -> t
  9808. | TType(t,tl) -> TType(t,List.map filter_param tl)
  9809. | TInst(c,tl) -> TInst(c,List.map filter_param tl)
  9810. | TEnum(e,tl) -> TEnum(e,List.map filter_param tl)
  9811. | TAbstract({ a_path = (["haxe";"extern"],"Rest") } as a,tl) -> TAbstract(a, List.map filter_param tl)
  9812. | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
  9813. filter_param (Abstract.get_underlying_type a tl)
  9814. | TAbstract(a,tl) -> TAbstract(a, List.map filter_param tl)
  9815. | TAnon a ->
  9816. TAnon {
  9817. a_fields = PMap.map (fun f -> { f with cf_type = filter_param f.cf_type }) a.a_fields;
  9818. a_status = a.a_status;
  9819. }
  9820. | TFun(args,ret) -> TFun(List.map (fun (n,o,t) -> (n,o,filter_param t)) args, filter_param ret)
  9821. | TDynamic _ -> t
  9822. | TLazy f -> filter_param (!f())
  9823. let default_implementation gen ~metas =
  9824. let rec run e =
  9825. match e.eexpr with
  9826. | TMeta(entry, e) when not (Hashtbl.mem metas entry) ->
  9827. run e
  9828. | _ ->
  9829. map_expr_type (fun e -> run e) filter_param (fun v -> v.v_type <- filter_param v.v_type; v) e
  9830. in
  9831. run
  9832. let default_implementation_module gen ~metas =
  9833. let rec run md = match md with
  9834. | TClassDecl cl ->
  9835. let rec map cf =
  9836. cf.cf_type <- filter_param cf.cf_type;
  9837. List.iter map cf.cf_overloads
  9838. in
  9839. List.iter map cl.cl_ordered_fields;
  9840. List.iter map cl.cl_ordered_statics;
  9841. Option.may map cl.cl_constructor;
  9842. md
  9843. | _ -> md
  9844. in
  9845. run
  9846. let configure gen ~metas =
  9847. let map e = Some(default_implementation gen e ~metas:metas) in
  9848. gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map;
  9849. let map md = Some(default_implementation_module gen ~metas md) in
  9850. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9851. end;;
  9852. (* ******************************************* *)
  9853. (* InterfaceMetas *)
  9854. (* ******************************************* *)
  9855. (*
  9856. Deal with metadata on interfaces by taking it off from interface, and adding a new class with `_HxMeta` suffix
  9857. dependencies:
  9858. Must run before InitFunction
  9859. *)
  9860. module InterfaceMetas =
  9861. struct
  9862. let name = "interface_metas"
  9863. let priority = solve_deps name [ DBefore InitFunction.priority ]
  9864. let traverse gen =
  9865. let run md = match md with
  9866. | TClassDecl ({ cl_interface = true; cl_ordered_statics = (_ :: _) } as cl) ->
  9867. cl.cl_ordered_statics <- [];
  9868. let path = fst cl.cl_path,snd cl.cl_path ^ "_HxMeta" in
  9869. (match Codegen.build_metadata gen.gcon (TClassDecl cl) with
  9870. | Some expr ->
  9871. let ncls = mk_class cl.cl_module path cl.cl_pos in
  9872. let cf = mk_class_field "__meta__" expr.etype false expr.epos (Var { v_read = AccNormal; v_write = AccNormal }) [] in
  9873. cf.cf_expr <- Some expr;
  9874. ncls.cl_statics <- PMap.add "__meta__" cf ncls.cl_statics;
  9875. ncls.cl_ordered_statics <- cf :: ncls.cl_ordered_statics;
  9876. gen.gadd_to_module (TClassDecl(ncls)) priority;
  9877. | _ -> ())
  9878. | _ -> ()
  9879. in
  9880. run
  9881. let configure gen =
  9882. let map md = traverse gen md; Some(md) in
  9883. gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map
  9884. end;;
  9885. (*
  9886. (* ******************************************* *)
  9887. (* Example *)
  9888. (* ******************************************* *)
  9889. (*
  9890. description
  9891. dependencies:
  9892. *)
  9893. module Example =
  9894. struct
  9895. let name = "example"
  9896. let priority = solve_deps name []
  9897. let default_implementation gen =
  9898. let rec run e =
  9899. match e.eexpr with
  9900. | _ -> Type.map_expr run e
  9901. in
  9902. run
  9903. let configure gen (mapping_func:texpr->texpr) =
  9904. let map e = Some(mapping_func e) in
  9905. gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
  9906. end;;
  9907. *)