symdef.pas 200 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (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., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { ppu }
  28. ppu,
  29. { node }
  30. node,
  31. { aasm }
  32. aasmbase,aasmtai,aasmdata,
  33. cpubase,cpuinfo,
  34. cgbase,cgutils,
  35. parabase
  36. ;
  37. type
  38. {************************************************
  39. TDef
  40. ************************************************}
  41. { tstoreddef }
  42. tstoreddef = class(tdef)
  43. protected
  44. typesymderef : tderef;
  45. public
  46. {$ifdef EXTDEBUG}
  47. fileinfo : tfileposinfo;
  48. {$endif}
  49. { generic support }
  50. genericdef : tstoreddef;
  51. genericdefderef : tderef;
  52. generictokenbuf : tdynamicarray;
  53. constructor create(dt:tdeftyp);
  54. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  55. destructor destroy;override;
  56. function getcopy : tstoreddef;virtual;
  57. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  58. procedure buildderef;override;
  59. procedure buildderefimpl;override;
  60. procedure deref;override;
  61. procedure derefimpl;override;
  62. function size:asizeint;override;
  63. function getvardef:longint;override;
  64. function alignment:shortint;override;
  65. function is_publishable : boolean;override;
  66. function needs_inittable : boolean;override;
  67. function rtti_mangledname(rt:trttitype):string;override;
  68. function OwnerHierarchyName: string; override;
  69. function in_currentunit: boolean;
  70. { regvars }
  71. function is_intregable : boolean;
  72. function is_fpuregable : boolean;
  73. { generics }
  74. procedure initgeneric;
  75. private
  76. savesize : asizeuint;
  77. end;
  78. tfiletyp = (ft_text,ft_typed,ft_untyped);
  79. tfiledef = class(tstoreddef)
  80. filetyp : tfiletyp;
  81. typedfiledef : tdef;
  82. typedfiledefderef : tderef;
  83. constructor createtext;
  84. constructor createuntyped;
  85. constructor createtyped(def : tdef);
  86. constructor ppuload(ppufile:tcompilerppufile);
  87. function getcopy : tstoreddef;override;
  88. procedure ppuwrite(ppufile:tcompilerppufile);override;
  89. procedure buildderef;override;
  90. procedure deref;override;
  91. function GetTypeName:string;override;
  92. function getmangledparaname:string;override;
  93. procedure setsize;
  94. end;
  95. tvariantdef = class(tstoreddef)
  96. varianttype : tvarianttype;
  97. constructor create(v : tvarianttype);
  98. constructor ppuload(ppufile:tcompilerppufile);
  99. function getcopy : tstoreddef;override;
  100. function GetTypeName:string;override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. function getvardef:longint;override;
  103. procedure setsize;
  104. function is_publishable : boolean;override;
  105. function needs_inittable : boolean;override;
  106. end;
  107. tformaldef = class(tstoreddef)
  108. typed:boolean;
  109. constructor create(Atyped:boolean);
  110. constructor ppuload(ppufile:tcompilerppufile);
  111. procedure ppuwrite(ppufile:tcompilerppufile);override;
  112. function GetTypeName:string;override;
  113. end;
  114. tforwarddef = class(tstoreddef)
  115. tosymname : pshortstring;
  116. forwardpos : tfileposinfo;
  117. constructor create(const s:string;const pos:tfileposinfo);
  118. destructor destroy;override;
  119. function getcopy:tstoreddef;override;
  120. function GetTypeName:string;override;
  121. end;
  122. tundefineddef = class(tstoreddef)
  123. constructor create;
  124. constructor ppuload(ppufile:tcompilerppufile);
  125. procedure ppuwrite(ppufile:tcompilerppufile);override;
  126. function GetTypeName:string;override;
  127. end;
  128. terrordef = class(tstoreddef)
  129. constructor create;
  130. procedure ppuwrite(ppufile:tcompilerppufile);override;
  131. function GetTypeName:string;override;
  132. function getmangledparaname : string;override;
  133. end;
  134. tabstractpointerdef = class(tstoreddef)
  135. pointeddef : tdef;
  136. pointeddefderef : tderef;
  137. constructor create(dt:tdeftyp;def:tdef);
  138. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  139. procedure ppuwrite(ppufile:tcompilerppufile);override;
  140. procedure buildderef;override;
  141. procedure deref;override;
  142. end;
  143. tpointerdef = class(tabstractpointerdef)
  144. is_far : boolean;
  145. has_pointer_math : boolean;
  146. constructor create(def:tdef);
  147. constructor createfar(def:tdef);
  148. function getcopy:tstoreddef;override;
  149. constructor ppuload(ppufile:tcompilerppufile);
  150. procedure ppuwrite(ppufile:tcompilerppufile);override;
  151. function GetTypeName:string;override;
  152. end;
  153. tprocdef = class;
  154. { tabstractrecorddef }
  155. tabstractrecorddef= class(tstoreddef)
  156. objname,
  157. objrealname : PShortString;
  158. { for C++ classes: name of the library this class is imported from }
  159. { for Java classes/records: package name }
  160. import_lib : PShortString;
  161. symtable : TSymtable;
  162. cloneddef : tabstractrecorddef;
  163. cloneddefderef : tderef;
  164. objectoptions : tobjectoptions;
  165. { for targets that initialise typed constants via explicit assignments
  166. instead of by generating an initialised data sectino }
  167. tcinitcode : tnode;
  168. constructor create(const n:string; dt:tdeftyp);
  169. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  170. procedure ppuwrite(ppufile:tcompilerppufile);override;
  171. destructor destroy; override;
  172. procedure check_forwards; virtual;
  173. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  174. function GetSymtable(t:tGetSymtable):TSymtable;override;
  175. function is_packed:boolean;
  176. function RttiName: string;
  177. { enumerator support }
  178. function search_enumerator_get: tprocdef; virtual;
  179. function search_enumerator_move: tprocdef; virtual;
  180. function search_enumerator_current: tsym; virtual;
  181. { JVM }
  182. function jvm_full_typename(with_package_name: boolean): string;
  183. end;
  184. trecorddef = class(tabstractrecorddef)
  185. public
  186. isunion : boolean;
  187. constructor create(const n:string; p:TSymtable);
  188. constructor ppuload(ppufile:tcompilerppufile);
  189. destructor destroy;override;
  190. function getcopy : tstoreddef;override;
  191. procedure ppuwrite(ppufile:tcompilerppufile);override;
  192. procedure buildderef;override;
  193. procedure deref;override;
  194. function size:asizeint;override;
  195. function alignment : shortint;override;
  196. function padalignment: shortint;
  197. function GetTypeName:string;override;
  198. { debug }
  199. function needs_inittable : boolean;override;
  200. { jvm }
  201. function is_related(d : tdef) : boolean;override;
  202. end;
  203. tobjectdef = class;
  204. { TImplementedInterface }
  205. TImplementedInterface = class
  206. IntfDef : tobjectdef;
  207. IntfDefDeref : tderef;
  208. IType : tinterfaceentrytype;
  209. IOffset : longint;
  210. VtblImplIntf : TImplementedInterface;
  211. NameMappings : TFPHashList;
  212. ProcDefs : TFPObjectList;
  213. ImplementsGetter : tsym;
  214. constructor create(aintf: tobjectdef);
  215. constructor create_deref(d:tderef);
  216. destructor destroy; override;
  217. function getcopy:TImplementedInterface;
  218. procedure buildderef;
  219. procedure deref;
  220. procedure AddMapping(const origname, newname: string);
  221. function GetMapping(const origname: string):string;
  222. procedure AddImplProc(pd:tprocdef);
  223. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  224. end;
  225. { tvmtentry }
  226. tvmtentry = record
  227. procdef : tprocdef;
  228. procdefderef : tderef;
  229. visibility : tvisibility;
  230. end;
  231. pvmtentry = ^tvmtentry;
  232. { tobjectdef }
  233. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  234. pmvcallstaticinfo = ^tmvcallstaticinfo;
  235. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  236. tobjectdef = class(tabstractrecorddef)
  237. private
  238. fcurrent_dispid: longint;
  239. public
  240. dwarf_struct_lab : tasmsymbol;
  241. childof : tobjectdef;
  242. childofderef : tderef;
  243. { for Object Pascal helpers }
  244. extendeddef : tabstractrecorddef;
  245. extendeddefderef: tderef;
  246. { for Objective-C: protocols and classes can have the same name there }
  247. objextname : pshortstring;
  248. { to be able to have a variable vmt position }
  249. { and no vmt field for objects without virtuals }
  250. vmtentries : TFPList;
  251. vmcallstaticinfo : pmvcallstaticinfo;
  252. vmt_offset : longint;
  253. iidguid : pguid;
  254. iidstr : pshortstring;
  255. { store implemented interfaces defs and name mappings }
  256. ImplementedInterfaces : TFPObjectList;
  257. writing_class_record_dbginfo,
  258. { a class of this type has been created in this module }
  259. created_in_current_module,
  260. { a loadvmtnode for this class has been created in this
  261. module, so if a classrefdef variable of this or a parent
  262. class is used somewhere to instantiate a class, then this
  263. class may be instantiated
  264. }
  265. maybe_created_in_current_module,
  266. { a "class of" this particular class has been created in
  267. this module
  268. }
  269. classref_created_in_current_module : boolean;
  270. objecttype : tobjecttyp;
  271. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
  272. constructor ppuload(ppufile:tcompilerppufile);
  273. destructor destroy;override;
  274. function getcopy : tstoreddef;override;
  275. procedure ppuwrite(ppufile:tcompilerppufile);override;
  276. function GetTypeName:string;override;
  277. procedure buildderef;override;
  278. procedure deref;override;
  279. procedure buildderefimpl;override;
  280. procedure derefimpl;override;
  281. procedure resetvmtentries;
  282. procedure copyvmtentries(objdef:tobjectdef);
  283. function getparentdef:tdef;override;
  284. function size : asizeint;override;
  285. function alignment:shortint;override;
  286. function vmtmethodoffset(index:longint):longint;
  287. function members_need_inittable : boolean;
  288. function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  289. { this should be called when this class implements an interface }
  290. procedure prepareguid;
  291. function is_publishable : boolean;override;
  292. function is_related(d : tdef) : boolean;override;
  293. function needs_inittable : boolean;override;
  294. function rtti_mangledname(rt:trttitype):string;override;
  295. function vmt_mangledname : string;
  296. procedure check_forwards; override;
  297. procedure insertvmt;
  298. procedure set_parent(c : tobjectdef);
  299. function find_destructor: tprocdef;
  300. function implements_any_interfaces: boolean;
  301. { dispinterface support }
  302. function get_next_dispid: longint;
  303. { enumerator support }
  304. function search_enumerator_get: tprocdef; override;
  305. function search_enumerator_move: tprocdef; override;
  306. function search_enumerator_current: tsym; override;
  307. { WPO }
  308. procedure register_created_object_type;override;
  309. procedure register_maybe_created_object_type;
  310. procedure register_created_classref_type;
  311. procedure register_vmt_call(index:longint);
  312. { ObjC }
  313. procedure finish_objc_data;
  314. function check_objc_types: boolean;
  315. { C++ }
  316. procedure finish_cpp_data;
  317. end;
  318. tclassrefdef = class(tabstractpointerdef)
  319. constructor create(def:tdef);
  320. constructor ppuload(ppufile:tcompilerppufile);
  321. procedure ppuwrite(ppufile:tcompilerppufile);override;
  322. function getcopy:tstoreddef;override;
  323. function GetTypeName:string;override;
  324. function is_publishable : boolean;override;
  325. function rtti_mangledname(rt:trttitype):string;override;
  326. procedure register_created_object_type;override;
  327. end;
  328. tarraydef = class(tstoreddef)
  329. lowrange,
  330. highrange : asizeint;
  331. rangedef : tdef;
  332. rangedefderef : tderef;
  333. arrayoptions : tarraydefoptions;
  334. symtable : TSymtable;
  335. protected
  336. _elementdef : tdef;
  337. _elementdefderef : tderef;
  338. procedure setelementdef(def:tdef);
  339. public
  340. function elesize : asizeint;
  341. function elepackedbitsize : asizeint;
  342. function elecount : asizeuint;
  343. constructor create_from_pointer(def:tdef);
  344. constructor create(l,h:asizeint;def:tdef);
  345. constructor ppuload(ppufile:tcompilerppufile);
  346. destructor destroy; override;
  347. function getcopy : tstoreddef;override;
  348. procedure ppuwrite(ppufile:tcompilerppufile);override;
  349. function GetTypeName:string;override;
  350. function getmangledparaname : string;override;
  351. procedure buildderef;override;
  352. procedure deref;override;
  353. function size : asizeint;override;
  354. function alignment : shortint;override;
  355. { returns the label of the range check string }
  356. function needs_inittable : boolean;override;
  357. property elementdef : tdef read _elementdef write setelementdef;
  358. function is_publishable : boolean;override;
  359. end;
  360. torddef = class(tstoreddef)
  361. low,high : TConstExprInt;
  362. ordtype : tordtype;
  363. constructor create(t : tordtype;v,b : TConstExprInt);
  364. constructor ppuload(ppufile:tcompilerppufile);
  365. function getcopy : tstoreddef;override;
  366. procedure ppuwrite(ppufile:tcompilerppufile);override;
  367. function is_publishable : boolean;override;
  368. function GetTypeName:string;override;
  369. function alignment:shortint;override;
  370. procedure setsize;
  371. function packedbitsize: asizeint; override;
  372. function getvardef : longint;override;
  373. end;
  374. tfloatdef = class(tstoreddef)
  375. floattype : tfloattype;
  376. constructor create(t : tfloattype);
  377. constructor ppuload(ppufile:tcompilerppufile);
  378. function getcopy : tstoreddef;override;
  379. procedure ppuwrite(ppufile:tcompilerppufile);override;
  380. function GetTypeName:string;override;
  381. function is_publishable : boolean;override;
  382. function alignment:shortint;override;
  383. procedure setsize;
  384. function getvardef:longint;override;
  385. end;
  386. { tabstractprocdef }
  387. tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
  388. pno_ownername, pno_noclassmarker, pno_noleadingdollar);
  389. tprocnameoptions = set of tprocnameoption;
  390. tabstractprocdef = class(tstoreddef)
  391. { saves a definition to the return type }
  392. returndef : tdef;
  393. returndefderef : tderef;
  394. parast : TSymtable;
  395. paras : tparalist;
  396. proctypeoption : tproctypeoption;
  397. proccalloption : tproccalloption;
  398. procoptions : tprocoptions;
  399. callerargareasize,
  400. calleeargareasize: pint;
  401. {$ifdef m68k}
  402. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  403. {$endif}
  404. funcretloc : array[tcallercallee] of TCGPara;
  405. has_paraloc_info : tcallercallee; { paraloc info is available }
  406. { number of user visible parameters }
  407. maxparacount,
  408. minparacount : byte;
  409. constructor create(dt:tdeftyp;level:byte);
  410. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  411. destructor destroy;override;
  412. procedure ppuwrite(ppufile:tcompilerppufile);override;
  413. procedure buildderef;override;
  414. procedure deref;override;
  415. procedure calcparas;
  416. function typename_paras(pno: tprocnameoptions): ansistring;
  417. function is_methodpointer:boolean;virtual;
  418. function is_addressonly:boolean;virtual;
  419. function no_self_node:boolean;
  420. procedure check_mark_as_nested;
  421. procedure init_paraloc_info(side: tcallercallee);
  422. function stack_tainting_parameter(side: tcallercallee): boolean;
  423. private
  424. procedure count_para(p:TObject;arg:pointer);
  425. procedure insert_para(p:TObject;arg:pointer);
  426. end;
  427. tprocvardef = class(tabstractprocdef)
  428. constructor create(level:byte);
  429. constructor ppuload(ppufile:tcompilerppufile);
  430. function getcopy : tstoreddef;override;
  431. procedure ppuwrite(ppufile:tcompilerppufile);override;
  432. function GetSymtable(t:tGetSymtable):TSymtable;override;
  433. function size : asizeint;override;
  434. function GetTypeName:string;override;
  435. function is_publishable : boolean;override;
  436. function is_methodpointer:boolean;override;
  437. function is_addressonly:boolean;override;
  438. function getmangledparaname:string;override;
  439. end;
  440. tmessageinf = record
  441. case integer of
  442. 0 : (str : pshortstring);
  443. 1 : (i : longint);
  444. end;
  445. tinlininginfo = record
  446. { node tree }
  447. code : tnode;
  448. flags : tprocinfoflags;
  449. end;
  450. pinlininginfo = ^tinlininginfo;
  451. { kinds of synthetic procdefs that can be generated }
  452. tsynthetickind = (
  453. tsk_none,
  454. tsk_anon_inherited, // anonymous inherited call
  455. tsk_jvm_clone, // Java-style clone method
  456. tsk_record_deepcopy, // deepcopy for records field by field
  457. tsk_empty, // an empty routine
  458. tsk_tcinit // initialisation of typed constants
  459. );
  460. {$ifdef oldregvars}
  461. { register variables }
  462. pregvarinfo = ^tregvarinfo;
  463. tregvarinfo = record
  464. regvars : array[1..maxvarregs] of tsym;
  465. regvars_para : array[1..maxvarregs] of boolean;
  466. regvars_refs : array[1..maxvarregs] of longint;
  467. fpuregvars : array[1..maxfpuvarregs] of tsym;
  468. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  469. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  470. end;
  471. {$endif oldregvars}
  472. { tprocdef }
  473. tprocdef = class(tabstractprocdef)
  474. private
  475. _mangledname : pshortstring;
  476. public
  477. messageinf : tmessageinf;
  478. dispid : longint;
  479. {$ifndef EXTDEBUG}
  480. { where is this function defined and what were the symbol
  481. flags, needed here because there
  482. is only one symbol for all overloaded functions
  483. EXTDEBUG has fileinfo in tdef (PFV) }
  484. fileinfo : tfileposinfo;
  485. {$endif}
  486. symoptions : tsymoptions;
  487. deprecatedmsg : pshortstring;
  488. { symbol owning this definition }
  489. procsym : tsym;
  490. procsymderef : tderef;
  491. { alias names }
  492. aliasnames : TCmdStrList;
  493. { symtables }
  494. localst : TSymtable;
  495. funcretsym : tsym;
  496. funcretsymderef : tderef;
  497. struct : tabstractrecorddef;
  498. structderef : tderef;
  499. {$if defined(powerpc) or defined(m68k)}
  500. { library symbol for AmigaOS/MorphOS }
  501. libsym : tsym;
  502. libsymderef : tderef;
  503. {$endif powerpc or m68k}
  504. { name of the result variable to insert in the localsymtable }
  505. resultname : pshortstring;
  506. { import info }
  507. import_dll,
  508. import_name : pshortstring;
  509. { info for inlining the subroutine, if this pointer is nil,
  510. the procedure can't be inlined }
  511. inlininginfo : pinlininginfo;
  512. {$ifdef jvm}
  513. { generated assembler code; used by JVM backend so it can afterwards
  514. easily write out all methods grouped per class }
  515. exprasmlist : TAsmList;
  516. {$endif jvm}
  517. {$ifdef oldregvars}
  518. regvarinfo: pregvarinfo;
  519. {$endif oldregvars}
  520. { interrupt vector }
  521. interruptvector : longint;
  522. { First/last assembler symbol/instruction in aasmoutput list.
  523. Note: initialised after compiling the code for the procdef, but
  524. not saved to/restored from ppu. Used when inserting debug info }
  525. procstarttai,
  526. procendtai : tai;
  527. import_nr : word;
  528. extnumber : word;
  529. {$ifdef i386}
  530. fpu_used : byte;
  531. {$endif i386}
  532. visibility : tvisibility;
  533. synthetickind : tsynthetickind;
  534. { true, if the procedure is only declared
  535. (forward procedure) }
  536. forwarddef,
  537. { true if the procedure is declared in the interface }
  538. interfacedef : boolean;
  539. { true if the procedure has a forward declaration }
  540. hasforward : boolean;
  541. constructor create(level:byte);
  542. constructor ppuload(ppufile:tcompilerppufile);
  543. destructor destroy;override;
  544. procedure ppuwrite(ppufile:tcompilerppufile);override;
  545. procedure buildderef;override;
  546. procedure buildderefimpl;override;
  547. procedure deref;override;
  548. procedure derefimpl;override;
  549. function GetSymtable(t:tGetSymtable):TSymtable;override;
  550. { warnings:
  551. * the symtablestack top has to be the symtable to which the copy
  552. should be added
  553. * getcopy does not create a finished/ready-to-use procdef; it
  554. needs to be finalised afterwards by calling
  555. symcreat.finish_copied_procdef() afterwards
  556. }
  557. function getcopy: tstoreddef; override;
  558. function GetTypeName : string;override;
  559. function mangledname : string;
  560. procedure setmangledname(const s : string);
  561. function fullprocname(showhidden:boolean):string;
  562. function customprocname(pno: tprocnameoptions):ansistring;
  563. function defaultmangledname: string;
  564. function cplusplusmangledname : string;
  565. function objcmangledname : string;
  566. function jvmmangledbasename: string;
  567. function is_methodpointer:boolean;override;
  568. function is_addressonly:boolean;override;
  569. procedure make_external;
  570. end;
  571. { single linked list of overloaded procs }
  572. pprocdeflist = ^tprocdeflist;
  573. tprocdeflist = record
  574. def : tprocdef;
  575. defderef : tderef;
  576. next : pprocdeflist;
  577. end;
  578. tstringdef = class(tstoreddef)
  579. stringtype : tstringtype;
  580. len : asizeint;
  581. constructor createshort(l : byte);
  582. constructor loadshort(ppufile:tcompilerppufile);
  583. constructor createlong(l : asizeint);
  584. constructor loadlong(ppufile:tcompilerppufile);
  585. constructor createansi;
  586. constructor loadansi(ppufile:tcompilerppufile);
  587. constructor createwide;
  588. constructor loadwide(ppufile:tcompilerppufile);
  589. constructor createunicode;
  590. constructor loadunicode(ppufile:tcompilerppufile);
  591. function getcopy : tstoreddef;override;
  592. function stringtypname:string;
  593. procedure ppuwrite(ppufile:tcompilerppufile);override;
  594. function GetTypeName:string;override;
  595. function getmangledparaname:string;override;
  596. function is_publishable : boolean;override;
  597. function alignment : shortint;override;
  598. function needs_inittable : boolean;override;
  599. function getvardef:longint;override;
  600. end;
  601. { tenumdef }
  602. tenumdef = class(tstoreddef)
  603. minval,
  604. maxval : asizeint;
  605. basedef : tenumdef;
  606. basedefderef : tderef;
  607. symtable : TSymtable;
  608. has_jumps : boolean;
  609. constructor create;
  610. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  611. constructor ppuload(ppufile:tcompilerppufile);
  612. destructor destroy;override;
  613. function getcopy : tstoreddef;override;
  614. procedure ppuwrite(ppufile:tcompilerppufile);override;
  615. procedure buildderef;override;
  616. procedure deref;override;
  617. function GetTypeName:string;override;
  618. function is_publishable : boolean;override;
  619. procedure calcsavesize;
  620. function packedbitsize: asizeint; override;
  621. procedure setmax(_max:asizeint);
  622. procedure setmin(_min:asizeint);
  623. function min:asizeint;
  624. function max:asizeint;
  625. function getfirstsym:tsym;
  626. end;
  627. tsetdef = class(tstoreddef)
  628. elementdef : tdef;
  629. elementdefderef : tderef;
  630. setbase,
  631. setmax : aword;
  632. constructor create(def:tdef;low, high : asizeint);
  633. constructor ppuload(ppufile:tcompilerppufile);
  634. function getcopy : tstoreddef;override;
  635. procedure ppuwrite(ppufile:tcompilerppufile);override;
  636. procedure buildderef;override;
  637. procedure deref;override;
  638. function GetTypeName:string;override;
  639. function is_publishable : boolean;override;
  640. end;
  641. tdefawaresymtablestack = class(TSymtablestack)
  642. private
  643. procedure addhelpers(st: TSymtable);
  644. procedure removehelpers(st: TSymtable);
  645. public
  646. procedure push(st: TSymtable); override;
  647. procedure pop(st: TSymtable); override;
  648. end;
  649. var
  650. current_structdef: tabstractrecorddef; { used for private functions check !! }
  651. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  652. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  653. { default types }
  654. generrordef, { error in definition }
  655. voidpointertype, { pointer for Void-pointeddef }
  656. charpointertype, { pointer for Char-pointeddef }
  657. widecharpointertype, { pointer for WideChar-pointeddef }
  658. voidfarpointertype,
  659. cundefinedtype,
  660. cformaltype, { unique formal definition }
  661. ctypedformaltype, { unique typed formal definition }
  662. voidtype, { Void (procedure) }
  663. cchartype, { Char }
  664. cwidechartype, { WideChar }
  665. pasbool8type, { boolean type }
  666. pasbool16type,
  667. pasbool32type,
  668. pasbool64type,
  669. bool8type,
  670. bool16type,
  671. bool32type,
  672. bool64type, { implement me }
  673. u8inttype, { 8-Bit unsigned integer }
  674. s8inttype, { 8-Bit signed integer }
  675. u16inttype, { 16-Bit unsigned integer }
  676. s16inttype, { 16-Bit signed integer }
  677. u32inttype, { 32-Bit unsigned integer }
  678. s32inttype, { 32-Bit signed integer }
  679. u64inttype, { 64-bit unsigned integer }
  680. s64inttype, { 64-bit signed integer }
  681. s32floattype, { 32 bit floating point number }
  682. s64floattype, { 64 bit floating point number }
  683. s80floattype, { 80 bit floating point number }
  684. sc80floattype, { 80 bit floating point number but stored like in C }
  685. s64currencytype, { pointer to a currency type }
  686. cshortstringtype, { pointer to type of short string const }
  687. clongstringtype, { pointer to type of long string const }
  688. cansistringtype, { pointer to type of ansi string const }
  689. cwidestringtype, { pointer to type of wide string const }
  690. cunicodestringtype,
  691. openshortstringtype, { pointer to type of an open shortstring,
  692. needed for readln() }
  693. openchararraytype, { pointer to type of an open array of char,
  694. needed for readln() }
  695. cfiletype, { get the same definition for all file }
  696. { used for stabs }
  697. methodpointertype, { typecasting of methodpointers to extract self }
  698. hresultdef,
  699. { we use only one variant def for every variant class }
  700. cvarianttype,
  701. colevarianttype,
  702. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  703. sinttype,
  704. uinttype,
  705. { unsigned and signed ord type with the same size as a pointer }
  706. ptruinttype,
  707. ptrsinttype,
  708. { several types to simulate more or less C++ objects for GDB }
  709. vmttype,
  710. vmtarraytype,
  711. pvmttype : tdef; { type of classrefs, used for stabs }
  712. { pointer to the anchestor of all classes }
  713. class_tobject : tobjectdef;
  714. { pointer to the ancestor of all COM interfaces }
  715. interface_iunknown : tobjectdef;
  716. { pointer to the ancestor of all dispinterfaces }
  717. interface_idispatch : tobjectdef;
  718. { pointer to the TGUID type
  719. of all interfaces }
  720. rec_tguid : trecorddef;
  721. { pointer to jump buffer }
  722. rec_jmp_buf : trecorddef;
  723. { Objective-C base types }
  724. objc_metaclasstype,
  725. objc_superclasstype,
  726. objc_idtype,
  727. objc_seltype : tpointerdef;
  728. objc_objecttype : trecorddef;
  729. { base type of @protocol(protocolname) Objective-C statements }
  730. objc_protocoltype : tobjectdef;
  731. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  732. objc_fastenumeration : tobjectdef;
  733. objc_fastenumerationstate : trecorddef;
  734. { Java base types }
  735. { java.lang.Object }
  736. java_jlobject : tobjectdef;
  737. { java.lang.Throwable }
  738. java_jlthrowable : tobjectdef;
  739. { FPC base type for records }
  740. java_fpcbaserecordtype : tobjectdef;
  741. { java.lang.String }
  742. java_jlstring : tobjectdef;
  743. const
  744. {$ifdef i386}
  745. pbestrealtype : ^tdef = @s80floattype;
  746. {$endif}
  747. {$ifdef x86_64}
  748. pbestrealtype : ^tdef = @s80floattype;
  749. {$endif}
  750. {$ifdef m68k}
  751. pbestrealtype : ^tdef = @s64floattype;
  752. {$endif}
  753. {$ifdef alpha}
  754. pbestrealtype : ^tdef = @s64floattype;
  755. {$endif}
  756. {$ifdef powerpc}
  757. pbestrealtype : ^tdef = @s64floattype;
  758. {$endif}
  759. {$ifdef POWERPC64}
  760. pbestrealtype : ^tdef = @s64floattype;
  761. {$endif}
  762. {$ifdef ia64}
  763. pbestrealtype : ^tdef = @s64floattype;
  764. {$endif}
  765. {$ifdef SPARC}
  766. pbestrealtype : ^tdef = @s64floattype;
  767. {$endif SPARC}
  768. {$ifdef vis}
  769. pbestrealtype : ^tdef = @s64floattype;
  770. {$endif vis}
  771. {$ifdef ARM}
  772. pbestrealtype : ^tdef = @s64floattype;
  773. {$endif ARM}
  774. {$ifdef MIPS}
  775. pbestrealtype : ^tdef = @s64floattype;
  776. {$endif MIPS}
  777. {$ifdef AVR}
  778. pbestrealtype : ^tdef = @s64floattype;
  779. {$endif AVR}
  780. {$ifdef JVM}
  781. pbestrealtype : ^tdef = @s64floattype;
  782. {$endif JVM}
  783. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  784. function make_dllmangledname(const dllname,importname:string;
  785. import_nr : word; pco : tproccalloption):string;
  786. { should be in the types unit, but the types unit uses the node stuff :( }
  787. function is_interfacecom(def: tdef): boolean;
  788. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  789. function is_any_interface_kind(def: tdef): boolean;
  790. function is_interfacecorba(def: tdef): boolean;
  791. function is_interface(def: tdef): boolean;
  792. function is_dispinterface(def: tdef): boolean;
  793. function is_object(def: tdef): boolean;
  794. function is_class(def: tdef): boolean;
  795. function is_cppclass(def: tdef): boolean;
  796. function is_objectpascal_helper(def: tdef): boolean;
  797. function is_objcclass(def: tdef): boolean;
  798. function is_objcclassref(def: tdef): boolean;
  799. function is_objcprotocol(def: tdef): boolean;
  800. function is_objccategory(def: tdef): boolean;
  801. function is_objc_class_or_protocol(def: tdef): boolean;
  802. function is_objc_protocol_or_category(def: tdef): boolean;
  803. function is_classhelper(def: tdef): boolean;
  804. function is_class_or_interface(def: tdef): boolean;
  805. function is_class_or_interface_or_objc(def: tdef): boolean;
  806. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  807. function is_class_or_interface_or_object(def: tdef): boolean;
  808. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  809. function is_implicit_pointer_object_type(def: tdef): boolean;
  810. function is_class_or_object(def: tdef): boolean;
  811. function is_record(def: tdef): boolean;
  812. function is_javaclass(def: tdef): boolean;
  813. function is_javainterface(def: tdef): boolean;
  814. function is_java_class_or_interface(def: tdef): boolean;
  815. procedure loadobjctypes;
  816. procedure maybeloadcocoatypes;
  817. function use_vectorfpu(def : tdef) : boolean;
  818. implementation
  819. uses
  820. SysUtils,
  821. cutils,
  822. { global }
  823. verbose,
  824. { target }
  825. systems,aasmcpu,paramgr,
  826. { symtable }
  827. symsym,symtable,symutil,defutil,objcdef,jvmdef,
  828. { module }
  829. fmodule,
  830. { other }
  831. gendef,
  832. fpccrc
  833. ;
  834. {****************************************************************************
  835. Helpers
  836. ****************************************************************************}
  837. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  838. var
  839. s,hs,
  840. prefix : string;
  841. oldlen,
  842. newlen,
  843. i : longint;
  844. crc : dword;
  845. hp : tparavarsym;
  846. begin
  847. prefix:='';
  848. if not assigned(st) then
  849. internalerror(200204212);
  850. { sub procedures }
  851. while (st.symtabletype=localsymtable) do
  852. begin
  853. if st.defowner.typ<>procdef then
  854. internalerror(200204173);
  855. { Add the full mangledname of procedure to prevent
  856. conflicts with 2 overloads having both a nested procedure
  857. with the same name, see tb0314 (PFV) }
  858. s:=tprocdef(st.defowner).procsym.name;
  859. oldlen:=length(s);
  860. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  861. begin
  862. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  863. if not(vo_is_hidden_para in hp.varoptions) then
  864. s:=s+'$'+hp.vardef.mangledparaname;
  865. end;
  866. if not is_void(tprocdef(st.defowner).returndef) then
  867. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  868. newlen:=length(s);
  869. { Replace with CRC if the parameter line is very long }
  870. if (newlen-oldlen>12) and
  871. ((newlen+length(prefix)>100) or (newlen-oldlen>32)) then
  872. begin
  873. crc:=0;
  874. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  875. begin
  876. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  877. if not(vo_is_hidden_para in hp.varoptions) then
  878. begin
  879. hs:=hp.vardef.mangledparaname;
  880. crc:=UpdateCrc32(crc,hs[1],length(hs));
  881. end;
  882. end;
  883. hs:=hp.vardef.mangledparaname;
  884. crc:=UpdateCrc32(crc,hs[1],length(hs));
  885. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  886. end;
  887. if prefix<>'' then
  888. prefix:=s+'_'+prefix
  889. else
  890. prefix:=s;
  891. if length(prefix)>100 then
  892. begin
  893. crc:=0;
  894. crc:=UpdateCrc32(crc,prefix[1],length(prefix));
  895. prefix:='$CRC'+hexstr(crc,8);
  896. end;
  897. st:=st.defowner.owner;
  898. end;
  899. { object/classes symtable, nested type definitions in classes require the while loop }
  900. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  901. begin
  902. if not (st.defowner.typ in [objectdef,recorddef]) then
  903. internalerror(200204174);
  904. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  905. st:=st.defowner.owner;
  906. end;
  907. { symtable must now be static or global }
  908. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  909. internalerror(200204175);
  910. result:='';
  911. if typeprefix<>'' then
  912. result:=result+typeprefix+'_';
  913. { Add P$ for program, which can have the same name as
  914. a unit }
  915. if (TSymtable(main_module.localsymtable)=st) and
  916. (not main_module.is_unit) then
  917. result:=result+'P$'+st.name^
  918. else
  919. result:=result+st.name^;
  920. if prefix<>'' then
  921. result:=result+'_'+prefix;
  922. if suffix<>'' then
  923. result:=result+'_'+suffix;
  924. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  925. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  926. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  927. { those in the debug map, leading to troubles with dsymutil). So always }
  928. { add an underscore on darwin. }
  929. if (target_info.system in systems_darwin) then
  930. result := '_' + result;
  931. end;
  932. function make_dllmangledname(const dllname,importname:string;import_nr : word; pco : tproccalloption):string;
  933. var
  934. crc : cardinal;
  935. i : longint;
  936. use_crc : boolean;
  937. dllprefix : string;
  938. begin
  939. if (target_info.system in (systems_all_windows + systems_nativent +
  940. [system_i386_emx, system_i386_os2]))
  941. and (dllname <> '') then
  942. begin
  943. dllprefix:=lower(ExtractFileName(dllname));
  944. { Remove .dll suffix if present }
  945. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  946. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  947. use_crc:=false;
  948. for i:=1 to length(dllprefix) do
  949. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  950. begin
  951. use_crc:=true;
  952. break;
  953. end;
  954. if use_crc then
  955. begin
  956. crc:=0;
  957. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  958. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  959. end
  960. else
  961. dllprefix:='_$dll$'+dllprefix+'$';
  962. if importname<>'' then
  963. result:=dllprefix+importname
  964. else
  965. result:=dllprefix+'_index_'+tostr(import_nr);
  966. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  967. { This allows to import VC++ mangled names from DLLs. }
  968. { Do not perform replacement, if external symbol is not imported from DLL. }
  969. if (dllname<>'') then
  970. begin
  971. Replace(result,'?','__q$$');
  972. {$ifdef arm}
  973. { @ symbol is not allowed in ARM assembler only }
  974. Replace(result,'@','__a$$');
  975. {$endif arm}
  976. end;
  977. end
  978. else
  979. begin
  980. if importname<>'' then
  981. begin
  982. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  983. result:=importname
  984. else
  985. result:=target_info.Cprefix+importname;
  986. end
  987. else
  988. result:='_index_'+tostr(import_nr);
  989. end;
  990. end;
  991. {****************************************************************************
  992. TDEFAWARESYMTABLESTACK
  993. (symtablestack descendant that does some special actions on
  994. the pushed/popped symtables)
  995. ****************************************************************************}
  996. procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
  997. var
  998. i: integer;
  999. s: string;
  1000. list: TFPObjectList;
  1001. def: tdef;
  1002. begin
  1003. { search the symtable from first to last; the helper to use will be the
  1004. last one in the list }
  1005. for i:=0 to st.symlist.count-1 do
  1006. begin
  1007. if not (st.symlist[i] is ttypesym) then
  1008. continue;
  1009. def:=ttypesym(st.SymList[i]).typedef;
  1010. if is_objectpascal_helper(def) then
  1011. begin
  1012. s:=make_mangledname('',tobjectdef(def).extendeddef.symtable,'');
  1013. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  1014. if not assigned(list) then
  1015. begin
  1016. list:=TFPObjectList.Create(false);
  1017. current_module.extendeddefs.Add(s,list);
  1018. end;
  1019. list.Add(def);
  1020. end
  1021. else
  1022. { add nested helpers as well }
  1023. if def.typ in [recorddef,objectdef] then
  1024. addhelpers(tabstractrecorddef(def).symtable);
  1025. end;
  1026. end;
  1027. procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
  1028. var
  1029. i, j: integer;
  1030. tmpst: TSymtable;
  1031. list: TFPObjectList;
  1032. begin
  1033. for i:=current_module.extendeddefs.count-1 downto 0 do
  1034. begin
  1035. list:=TFPObjectList(current_module.extendeddefs[i]);
  1036. for j:=list.count-1 downto 0 do
  1037. begin
  1038. if not (list[j] is tobjectdef) then
  1039. Internalerror(2011031501);
  1040. tmpst:=tobjectdef(list[j]).owner;
  1041. repeat
  1042. if tmpst=st then
  1043. begin
  1044. list.delete(j);
  1045. break;
  1046. end
  1047. else
  1048. begin
  1049. if assigned(tmpst.defowner) then
  1050. tmpst:=tmpst.defowner.owner
  1051. else
  1052. tmpst:=nil;
  1053. end;
  1054. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1055. end;
  1056. if list.count=0 then
  1057. current_module.extendeddefs.delete(i);
  1058. end;
  1059. end;
  1060. procedure tdefawaresymtablestack.push(st: TSymtable);
  1061. begin
  1062. { nested helpers will be added as well }
  1063. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1064. (sto_has_helper in st.tableoptions) then
  1065. addhelpers(st);
  1066. inherited push(st);
  1067. end;
  1068. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1069. begin
  1070. inherited pop(st);
  1071. { nested helpers will be removed as well }
  1072. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1073. (sto_has_helper in st.tableoptions) then
  1074. removehelpers(st);
  1075. end;
  1076. {****************************************************************************
  1077. TDEF (base class for definitions)
  1078. ****************************************************************************}
  1079. constructor tstoreddef.create(dt:tdeftyp);
  1080. var
  1081. insertstack : psymtablestackitem;
  1082. begin
  1083. inherited create(dt);
  1084. savesize := 0;
  1085. {$ifdef EXTDEBUG}
  1086. fileinfo := current_filepos;
  1087. {$endif}
  1088. generictokenbuf:=nil;
  1089. genericdef:=nil;
  1090. { Don't register forwarddefs, they are disposed at the
  1091. end of an type block }
  1092. if (dt=forwarddef) then
  1093. exit;
  1094. { Register in current_module }
  1095. if assigned(current_module) then
  1096. begin
  1097. current_module.deflist.Add(self);
  1098. DefId:=current_module.deflist.Count-1;
  1099. end;
  1100. { Register in symtable stack }
  1101. if assigned(symtablestack) then
  1102. begin
  1103. insertstack:=symtablestack.stack;
  1104. while assigned(insertstack) and
  1105. (insertstack^.symtable.symtabletype=withsymtable) do
  1106. insertstack:=insertstack^.next;
  1107. if not assigned(insertstack) then
  1108. internalerror(200602044);
  1109. insertstack^.symtable.insertdef(self);
  1110. end;
  1111. end;
  1112. destructor tstoreddef.destroy;
  1113. begin
  1114. { Direct calls are not allowed, use symtable.deletedef() }
  1115. if assigned(owner) then
  1116. internalerror(200612311);
  1117. if assigned(generictokenbuf) then
  1118. begin
  1119. generictokenbuf.free;
  1120. generictokenbuf:=nil;
  1121. end;
  1122. inherited destroy;
  1123. end;
  1124. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1125. var
  1126. sizeleft,i : longint;
  1127. buf : array[0..255] of byte;
  1128. begin
  1129. inherited create(dt);
  1130. DefId:=ppufile.getlongint;
  1131. current_module.deflist[DefId]:=self;
  1132. {$ifdef EXTDEBUG}
  1133. fillchar(fileinfo,sizeof(fileinfo),0);
  1134. {$endif}
  1135. { load }
  1136. ppufile.getderef(typesymderef);
  1137. ppufile.getsmallset(defoptions);
  1138. ppufile.getsmallset(defstates);
  1139. if df_generic in defoptions then
  1140. begin
  1141. sizeleft:=ppufile.getlongint;
  1142. initgeneric;
  1143. while sizeleft>0 do
  1144. begin
  1145. if sizeleft>sizeof(buf) then
  1146. i:=sizeof(buf)
  1147. else
  1148. i:=sizeleft;
  1149. ppufile.getdata(buf,i);
  1150. generictokenbuf.write(buf,i);
  1151. dec(sizeleft,i);
  1152. end;
  1153. end;
  1154. if df_specialization in defoptions then
  1155. ppufile.getderef(genericdefderef);
  1156. end;
  1157. function Tstoreddef.rtti_mangledname(rt:trttitype):string;
  1158. var
  1159. prefix : string[4];
  1160. begin
  1161. if rt=fullrtti then
  1162. begin
  1163. prefix:='RTTI';
  1164. include(defstates,ds_rtti_table_used);
  1165. end
  1166. else
  1167. begin
  1168. prefix:='INIT';
  1169. include(defstates,ds_init_table_used);
  1170. end;
  1171. if assigned(typesym) and
  1172. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1173. result:=make_mangledname(prefix,owner,typesym.name)
  1174. else
  1175. result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
  1176. end;
  1177. function tstoreddef.OwnerHierarchyName: string;
  1178. var
  1179. tmp: tdef;
  1180. begin
  1181. tmp:=self;
  1182. result:='';
  1183. repeat
  1184. if tmp.owner.symtabletype in [ObjectSymtable,recordsymtable] then
  1185. tmp:=tdef(tmp.owner.defowner)
  1186. else
  1187. break;
  1188. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1189. until tmp=nil;
  1190. end;
  1191. function tstoreddef.in_currentunit: boolean;
  1192. var
  1193. st: tsymtable;
  1194. begin
  1195. st:=owner;
  1196. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  1197. st:=st.defowner.owner;
  1198. result:=st.iscurrentunit;
  1199. end;
  1200. function tstoreddef.getcopy : tstoreddef;
  1201. begin
  1202. Message(sym_e_cant_create_unique_type);
  1203. getcopy:=terrordef.create;
  1204. end;
  1205. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  1206. var
  1207. sizeleft,i : longint;
  1208. buf : array[0..255] of byte;
  1209. oldintfcrc : boolean;
  1210. begin
  1211. ppufile.putlongint(DefId);
  1212. ppufile.putderef(typesymderef);
  1213. ppufile.putsmallset(defoptions);
  1214. oldintfcrc:=ppufile.do_crc;
  1215. ppufile.do_crc:=false;
  1216. ppufile.putsmallset(defstates);
  1217. if df_generic in defoptions then
  1218. begin
  1219. if assigned(generictokenbuf) then
  1220. begin
  1221. sizeleft:=generictokenbuf.size;
  1222. generictokenbuf.seek(0);
  1223. end
  1224. else
  1225. sizeleft:=0;
  1226. ppufile.putlongint(sizeleft);
  1227. while sizeleft>0 do
  1228. begin
  1229. if sizeleft>sizeof(buf) then
  1230. i:=sizeof(buf)
  1231. else
  1232. i:=sizeleft;
  1233. generictokenbuf.read(buf,i);
  1234. ppufile.putdata(buf,i);
  1235. dec(sizeleft,i);
  1236. end;
  1237. end;
  1238. ppufile.do_crc:=oldintfcrc;
  1239. if df_specialization in defoptions then
  1240. ppufile.putderef(genericdefderef);
  1241. end;
  1242. procedure tstoreddef.buildderef;
  1243. begin
  1244. typesymderef.build(typesym);
  1245. genericdefderef.build(genericdef);
  1246. end;
  1247. procedure tstoreddef.buildderefimpl;
  1248. begin
  1249. end;
  1250. procedure tstoreddef.deref;
  1251. begin
  1252. typesym:=ttypesym(typesymderef.resolve);
  1253. if df_specialization in defoptions then
  1254. genericdef:=tstoreddef(genericdefderef.resolve);
  1255. end;
  1256. procedure tstoreddef.derefimpl;
  1257. begin
  1258. end;
  1259. function tstoreddef.size : asizeint;
  1260. begin
  1261. size:=savesize;
  1262. end;
  1263. function tstoreddef.getvardef:longint;
  1264. begin
  1265. result:=varUndefined;
  1266. end;
  1267. function tstoreddef.alignment : shortint;
  1268. begin
  1269. { natural alignment by default }
  1270. alignment:=size_2_align(savesize);
  1271. { can happen if savesize = 0, e.g. for voiddef or
  1272. an empty record
  1273. }
  1274. if (alignment=0) then
  1275. alignment:=1;
  1276. end;
  1277. { returns true, if the definition can be published }
  1278. function tstoreddef.is_publishable : boolean;
  1279. begin
  1280. is_publishable:=false;
  1281. end;
  1282. { needs an init table }
  1283. function tstoreddef.needs_inittable : boolean;
  1284. begin
  1285. needs_inittable:=false;
  1286. end;
  1287. function tstoreddef.is_intregable : boolean;
  1288. var
  1289. recsize,temp: longint;
  1290. begin
  1291. is_intregable:=false;
  1292. case typ of
  1293. orddef,
  1294. pointerdef,
  1295. enumdef,
  1296. classrefdef:
  1297. is_intregable:=true;
  1298. procvardef :
  1299. is_intregable:=tprocvardef(self).is_addressonly;
  1300. objectdef:
  1301. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  1302. setdef:
  1303. is_intregable:=is_smallset(self);
  1304. recorddef:
  1305. begin
  1306. recsize:=size;
  1307. is_intregable:=
  1308. ispowerof2(recsize,temp) and
  1309. (recsize <= sizeof(asizeint));
  1310. end;
  1311. end;
  1312. end;
  1313. function tstoreddef.is_fpuregable : boolean;
  1314. begin
  1315. {$ifdef x86}
  1316. result:=use_vectorfpu(self);
  1317. {$else x86}
  1318. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  1319. {$endif x86}
  1320. end;
  1321. procedure tstoreddef.initgeneric;
  1322. begin
  1323. if assigned(generictokenbuf) then
  1324. internalerror(200512131);
  1325. generictokenbuf:=tdynamicarray.create(256);
  1326. end;
  1327. {****************************************************************************
  1328. Tstringdef
  1329. ****************************************************************************}
  1330. constructor tstringdef.createshort(l : byte);
  1331. begin
  1332. inherited create(stringdef);
  1333. stringtype:=st_shortstring;
  1334. len:=l;
  1335. savesize:=len+1;
  1336. end;
  1337. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1338. begin
  1339. inherited ppuload(stringdef,ppufile);
  1340. stringtype:=st_shortstring;
  1341. len:=ppufile.getbyte;
  1342. savesize:=len+1;
  1343. end;
  1344. constructor tstringdef.createlong(l : asizeint);
  1345. begin
  1346. inherited create(stringdef);
  1347. stringtype:=st_longstring;
  1348. len:=l;
  1349. savesize:=sizeof(pint);
  1350. end;
  1351. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1352. begin
  1353. inherited ppuload(stringdef,ppufile);
  1354. stringtype:=st_longstring;
  1355. len:=ppufile.getasizeint;
  1356. savesize:=sizeof(pint);
  1357. end;
  1358. constructor tstringdef.createansi;
  1359. begin
  1360. inherited create(stringdef);
  1361. stringtype:=st_ansistring;
  1362. len:=-1;
  1363. savesize:=sizeof(pint);
  1364. end;
  1365. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1366. begin
  1367. inherited ppuload(stringdef,ppufile);
  1368. stringtype:=st_ansistring;
  1369. len:=ppufile.getaint;
  1370. savesize:=sizeof(pint);
  1371. end;
  1372. constructor tstringdef.createwide;
  1373. begin
  1374. inherited create(stringdef);
  1375. stringtype:=st_widestring;
  1376. len:=-1;
  1377. savesize:=sizeof(pint);
  1378. end;
  1379. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1380. begin
  1381. inherited ppuload(stringdef,ppufile);
  1382. stringtype:=st_widestring;
  1383. len:=ppufile.getaint;
  1384. savesize:=sizeof(pint);
  1385. end;
  1386. constructor tstringdef.createunicode;
  1387. begin
  1388. inherited create(stringdef);
  1389. stringtype:=st_unicodestring;
  1390. len:=-1;
  1391. savesize:=sizeof(pint);
  1392. end;
  1393. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  1394. begin
  1395. inherited ppuload(stringdef,ppufile);
  1396. stringtype:=st_unicodestring;
  1397. len:=ppufile.getaint;
  1398. savesize:=sizeof(pint);
  1399. end;
  1400. function tstringdef.getcopy : tstoreddef;
  1401. begin
  1402. result:=tstringdef.create(typ);
  1403. result.typ:=stringdef;
  1404. tstringdef(result).stringtype:=stringtype;
  1405. tstringdef(result).len:=len;
  1406. tstringdef(result).savesize:=savesize;
  1407. end;
  1408. function tstringdef.stringtypname:string;
  1409. const
  1410. typname:array[tstringtype] of string[10]=(
  1411. 'shortstr','longstr','ansistr','widestr','unicodestr'
  1412. );
  1413. begin
  1414. stringtypname:=typname[stringtype];
  1415. end;
  1416. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1417. begin
  1418. inherited ppuwrite(ppufile);
  1419. if stringtype=st_shortstring then
  1420. begin
  1421. {$ifdef extdebug}
  1422. if len > 255 then internalerror(12122002);
  1423. {$endif}
  1424. ppufile.putbyte(byte(len))
  1425. end
  1426. else
  1427. ppufile.putaint(len);
  1428. case stringtype of
  1429. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1430. st_longstring : ppufile.writeentry(iblongstringdef);
  1431. st_ansistring : ppufile.writeentry(ibansistringdef);
  1432. st_widestring : ppufile.writeentry(ibwidestringdef);
  1433. st_unicodestring : ppufile.writeentry(ibunicodestringdef);
  1434. end;
  1435. end;
  1436. function tstringdef.needs_inittable : boolean;
  1437. begin
  1438. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  1439. end;
  1440. function tstringdef.GetTypeName : string;
  1441. const
  1442. names : array[tstringtype] of string[15] = (
  1443. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  1444. begin
  1445. GetTypeName:=names[stringtype];
  1446. end;
  1447. function tstringdef.getvardef : longint;
  1448. const
  1449. vardef : array[tstringtype] of longint = (
  1450. varUndefined,varUndefined,varString,varOleStr,varUString);
  1451. begin
  1452. result:=vardef[stringtype];
  1453. end;
  1454. function tstringdef.alignment : shortint;
  1455. begin
  1456. case stringtype of
  1457. st_unicodestring,
  1458. st_widestring,
  1459. st_ansistring:
  1460. alignment:=size_2_align(savesize);
  1461. st_longstring,
  1462. st_shortstring:
  1463. { char to string accesses byte 0 and 1 with one word access }
  1464. if (tf_requires_proper_alignment in target_info.flags) or
  1465. { macpas needs an alignment of 2 (MetroWerks compatible) }
  1466. (m_mac in current_settings.modeswitches) then
  1467. alignment:=size_2_align(2)
  1468. else
  1469. alignment:=size_2_align(1);
  1470. else
  1471. internalerror(200412301);
  1472. end;
  1473. end;
  1474. function tstringdef.getmangledparaname : string;
  1475. begin
  1476. getmangledparaname:='STRING';
  1477. end;
  1478. function tstringdef.is_publishable : boolean;
  1479. begin
  1480. is_publishable:=true;
  1481. end;
  1482. {****************************************************************************
  1483. TENUMDEF
  1484. ****************************************************************************}
  1485. constructor tenumdef.create;
  1486. begin
  1487. inherited create(enumdef);
  1488. minval:=0;
  1489. maxval:=0;
  1490. calcsavesize;
  1491. has_jumps:=false;
  1492. basedef:=nil;
  1493. symtable:=tenumsymtable.create(self);
  1494. end;
  1495. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  1496. begin
  1497. inherited create(enumdef);
  1498. minval:=_min;
  1499. maxval:=_max;
  1500. basedef:=_basedef;
  1501. calcsavesize;
  1502. has_jumps:=false;
  1503. symtable:=basedef.symtable.getcopy;
  1504. include(defoptions, df_copied_def);
  1505. end;
  1506. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1507. begin
  1508. inherited ppuload(enumdef,ppufile);
  1509. minval:=ppufile.getaint;
  1510. maxval:=ppufile.getaint;
  1511. savesize:=ppufile.getaint;
  1512. has_jumps:=false;
  1513. if df_copied_def in defoptions then
  1514. begin
  1515. symtable:=nil;
  1516. ppufile.getderef(basedefderef);
  1517. end
  1518. else
  1519. begin
  1520. // create with nil defowner first to prevent values changes on insert
  1521. symtable:=tenumsymtable.create(nil);
  1522. tenumsymtable(symtable).ppuload(ppufile);
  1523. symtable.defowner:=self;
  1524. end;
  1525. end;
  1526. destructor tenumdef.destroy;
  1527. begin
  1528. symtable.free;
  1529. symtable:=nil;
  1530. inherited destroy;
  1531. end;
  1532. function tenumdef.getcopy : tstoreddef;
  1533. begin
  1534. if assigned(basedef) then
  1535. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1536. else
  1537. begin
  1538. result:=tenumdef.create;
  1539. tenumdef(result).minval:=minval;
  1540. tenumdef(result).maxval:=maxval;
  1541. tenumdef(result).symtable.free;
  1542. tenumdef(result).symtable:=symtable.getcopy;
  1543. tenumdef(result).basedef:=self;
  1544. end;
  1545. tenumdef(result).has_jumps:=has_jumps;
  1546. tenumdef(result).basedefderef:=basedefderef;
  1547. include(tenumdef(result).defoptions,df_copied_def);
  1548. end;
  1549. procedure tenumdef.calcsavesize;
  1550. begin
  1551. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1552. savesize:=8
  1553. else
  1554. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1555. savesize:=4
  1556. else
  1557. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1558. savesize:=2
  1559. else
  1560. savesize:=1;
  1561. end;
  1562. function tenumdef.packedbitsize: asizeint;
  1563. var
  1564. sizeval: tconstexprint;
  1565. power: longint;
  1566. begin
  1567. result := 0;
  1568. if (minval >= 0) and
  1569. (maxval <= 1) then
  1570. result := 1
  1571. else
  1572. begin
  1573. if (minval>=0) then
  1574. sizeval:=maxval
  1575. else
  1576. { don't count 0 twice }
  1577. sizeval:=(cutils.max(-minval,maxval)*2)-1;
  1578. { 256 must become 512 etc. }
  1579. nextpowerof2(sizeval+1,power);
  1580. result := power;
  1581. end;
  1582. end;
  1583. procedure tenumdef.setmax(_max:asizeint);
  1584. begin
  1585. maxval:=_max;
  1586. calcsavesize;
  1587. end;
  1588. procedure tenumdef.setmin(_min:asizeint);
  1589. begin
  1590. minval:=_min;
  1591. calcsavesize;
  1592. end;
  1593. function tenumdef.min:asizeint;
  1594. begin
  1595. min:=minval;
  1596. end;
  1597. function tenumdef.max:asizeint;
  1598. begin
  1599. max:=maxval;
  1600. end;
  1601. function tenumdef.getfirstsym: tsym;
  1602. var
  1603. i:integer;
  1604. begin
  1605. for i := 0 to symtable.SymList.Count - 1 do
  1606. begin
  1607. result:=tsym(symtable.SymList[i]);
  1608. if tenumsym(result).value=minval then
  1609. exit;
  1610. end;
  1611. result:=nil;
  1612. end;
  1613. procedure tenumdef.buildderef;
  1614. begin
  1615. inherited buildderef;
  1616. if df_copied_def in defoptions then
  1617. basedefderef.build(basedef)
  1618. else
  1619. tenumsymtable(symtable).buildderef;
  1620. end;
  1621. procedure tenumdef.deref;
  1622. begin
  1623. inherited deref;
  1624. if df_copied_def in defoptions then
  1625. begin
  1626. basedef:=tenumdef(basedefderef.resolve);
  1627. symtable:=basedef.symtable.getcopy;
  1628. end
  1629. else
  1630. tenumsymtable(symtable).deref;
  1631. end;
  1632. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1633. begin
  1634. inherited ppuwrite(ppufile);
  1635. ppufile.putaint(min);
  1636. ppufile.putaint(max);
  1637. ppufile.putaint(savesize);
  1638. if df_copied_def in defoptions then
  1639. ppufile.putderef(basedefderef);
  1640. ppufile.writeentry(ibenumdef);
  1641. if not (df_copied_def in defoptions) then
  1642. tenumsymtable(symtable).ppuwrite(ppufile);
  1643. end;
  1644. function tenumdef.is_publishable : boolean;
  1645. begin
  1646. is_publishable:=true;
  1647. end;
  1648. function tenumdef.GetTypeName : string;
  1649. begin
  1650. GetTypeName:='<enumeration type>';
  1651. end;
  1652. {****************************************************************************
  1653. TORDDEF
  1654. ****************************************************************************}
  1655. constructor torddef.create(t : tordtype;v,b : TConstExprInt);
  1656. begin
  1657. inherited create(orddef);
  1658. low:=v;
  1659. high:=b;
  1660. ordtype:=t;
  1661. setsize;
  1662. end;
  1663. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1664. begin
  1665. inherited ppuload(orddef,ppufile);
  1666. ordtype:=tordtype(ppufile.getbyte);
  1667. low:=ppufile.getexprint;
  1668. high:=ppufile.getexprint;
  1669. setsize;
  1670. end;
  1671. function torddef.getcopy : tstoreddef;
  1672. begin
  1673. result:=torddef.create(ordtype,low,high);
  1674. result.typ:=orddef;
  1675. torddef(result).low:=low;
  1676. torddef(result).high:=high;
  1677. torddef(result).ordtype:=ordtype;
  1678. torddef(result).savesize:=savesize;
  1679. end;
  1680. function torddef.alignment:shortint;
  1681. begin
  1682. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) and
  1683. (ordtype in [s64bit,u64bit]) then
  1684. result := 4
  1685. else
  1686. result := inherited alignment;
  1687. end;
  1688. procedure torddef.setsize;
  1689. const
  1690. sizetbl : array[tordtype] of longint = (
  1691. 0,
  1692. 1,2,4,8,
  1693. 1,2,4,8,
  1694. 1,2,4,8,
  1695. 1,2,4,8,
  1696. 1,2,8
  1697. );
  1698. begin
  1699. savesize:=sizetbl[ordtype];
  1700. end;
  1701. function torddef.packedbitsize: asizeint;
  1702. var
  1703. sizeval: tconstexprint;
  1704. power: longint;
  1705. begin
  1706. result := 0;
  1707. if ordtype = uvoid then
  1708. exit;
  1709. {$ifndef cpu64bitalu}
  1710. if (ordtype in [s64bit,u64bit]) then
  1711. {$else not cpu64bitalu}
  1712. if (ordtype = u64bit) or
  1713. ((ordtype = s64bit) and
  1714. ((low <= (system.low(int64) div 2)) or
  1715. (high > (system.high(int64) div 2)))) then
  1716. {$endif cpu64bitalu}
  1717. result := 64
  1718. else if (low >= 0) and
  1719. (high <= 1) then
  1720. result := 1
  1721. else
  1722. begin
  1723. if (low>=0) then
  1724. sizeval:=high
  1725. else
  1726. { don't count 0 twice }
  1727. sizeval:=(cutils.max(-low,high)*2)-1;
  1728. { 256 must become 512 etc. }
  1729. nextpowerof2(sizeval+1,power);
  1730. result := power;
  1731. end;
  1732. end;
  1733. function torddef.getvardef : longint;
  1734. const
  1735. basetype2vardef : array[tordtype] of longint = (
  1736. varUndefined,
  1737. varbyte,varword,varlongword,varqword,
  1738. varshortint,varsmallint,varinteger,varint64,
  1739. varboolean,varboolean,varboolean,varboolean,
  1740. varboolean,varboolean,varUndefined,varUndefined,
  1741. varUndefined,varUndefined,varCurrency);
  1742. begin
  1743. result:=basetype2vardef[ordtype];
  1744. end;
  1745. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1746. begin
  1747. inherited ppuwrite(ppufile);
  1748. ppufile.putbyte(byte(ordtype));
  1749. ppufile.putexprint(low);
  1750. ppufile.putexprint(high);
  1751. ppufile.writeentry(iborddef);
  1752. end;
  1753. function torddef.is_publishable : boolean;
  1754. begin
  1755. is_publishable:=(ordtype<>uvoid);
  1756. end;
  1757. function torddef.GetTypeName : string;
  1758. const
  1759. names : array[tordtype] of string[20] = (
  1760. 'untyped',
  1761. 'Byte','Word','DWord','QWord',
  1762. 'ShortInt','SmallInt','LongInt','Int64',
  1763. 'Boolean','Boolean16','Boolean32','Boolean64',
  1764. 'ByteBool','WordBool','LongBool','QWordBool',
  1765. 'Char','WideChar','Currency');
  1766. begin
  1767. GetTypeName:=names[ordtype];
  1768. end;
  1769. {****************************************************************************
  1770. TFLOATDEF
  1771. ****************************************************************************}
  1772. constructor tfloatdef.create(t : tfloattype);
  1773. begin
  1774. inherited create(floatdef);
  1775. floattype:=t;
  1776. setsize;
  1777. end;
  1778. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1779. begin
  1780. inherited ppuload(floatdef,ppufile);
  1781. floattype:=tfloattype(ppufile.getbyte);
  1782. setsize;
  1783. end;
  1784. function tfloatdef.getcopy : tstoreddef;
  1785. begin
  1786. result:=tfloatdef.create(floattype);
  1787. result.typ:=floatdef;
  1788. tfloatdef(result).savesize:=savesize;
  1789. end;
  1790. function tfloatdef.alignment:shortint;
  1791. begin
  1792. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) then
  1793. case floattype of
  1794. s80real: result:=16;
  1795. s64real,
  1796. s64currency,
  1797. s64comp : result:=4;
  1798. else
  1799. result := inherited alignment;
  1800. end
  1801. else
  1802. result := inherited alignment;
  1803. end;
  1804. procedure tfloatdef.setsize;
  1805. begin
  1806. case floattype of
  1807. s32real : savesize:=4;
  1808. s80real : savesize:=10;
  1809. sc80real:
  1810. if target_info.system in [system_i386_darwin,system_i386_iphonesim,system_x86_64_darwin,
  1811. system_x86_64_linux,system_x86_64_freebsd,
  1812. system_x86_64_solaris,system_x86_64_embedded] then
  1813. savesize:=16
  1814. else
  1815. savesize:=12;
  1816. s64real,
  1817. s64currency,
  1818. s64comp : savesize:=8;
  1819. else
  1820. savesize:=0;
  1821. end;
  1822. end;
  1823. function tfloatdef.getvardef : longint;
  1824. const
  1825. floattype2vardef : array[tfloattype] of longint = (
  1826. varSingle,varDouble,varUndefined,varUndefined,
  1827. varUndefined,varCurrency,varUndefined);
  1828. begin
  1829. if (upper(typename)='TDATETIME') and
  1830. assigned(owner) and
  1831. assigned(owner.name) and
  1832. (owner.name^='SYSTEM') then
  1833. result:=varDate
  1834. else
  1835. result:=floattype2vardef[floattype];
  1836. end;
  1837. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1838. begin
  1839. inherited ppuwrite(ppufile);
  1840. ppufile.putbyte(byte(floattype));
  1841. ppufile.writeentry(ibfloatdef);
  1842. end;
  1843. function tfloatdef.is_publishable : boolean;
  1844. begin
  1845. is_publishable:=true;
  1846. end;
  1847. function tfloatdef.GetTypeName : string;
  1848. const
  1849. names : array[tfloattype] of string[20] = (
  1850. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  1851. begin
  1852. GetTypeName:=names[floattype];
  1853. end;
  1854. {****************************************************************************
  1855. TFILEDEF
  1856. ****************************************************************************}
  1857. constructor tfiledef.createtext;
  1858. begin
  1859. inherited create(filedef);
  1860. filetyp:=ft_text;
  1861. typedfiledef:=nil;
  1862. setsize;
  1863. end;
  1864. constructor tfiledef.createuntyped;
  1865. begin
  1866. inherited create(filedef);
  1867. filetyp:=ft_untyped;
  1868. typedfiledef:=nil;
  1869. setsize;
  1870. end;
  1871. constructor tfiledef.createtyped(def:tdef);
  1872. begin
  1873. inherited create(filedef);
  1874. filetyp:=ft_typed;
  1875. typedfiledef:=def;
  1876. setsize;
  1877. end;
  1878. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1879. begin
  1880. inherited ppuload(filedef,ppufile);
  1881. filetyp:=tfiletyp(ppufile.getbyte);
  1882. if filetyp=ft_typed then
  1883. ppufile.getderef(typedfiledefderef)
  1884. else
  1885. typedfiledef:=nil;
  1886. setsize;
  1887. end;
  1888. function tfiledef.getcopy : tstoreddef;
  1889. begin
  1890. case filetyp of
  1891. ft_typed:
  1892. result:=tfiledef.createtyped(typedfiledef);
  1893. ft_untyped:
  1894. result:=tfiledef.createuntyped;
  1895. ft_text:
  1896. result:=tfiledef.createtext;
  1897. else
  1898. internalerror(2004121201);
  1899. end;
  1900. end;
  1901. procedure tfiledef.buildderef;
  1902. begin
  1903. inherited buildderef;
  1904. if filetyp=ft_typed then
  1905. typedfiledefderef.build(typedfiledef);
  1906. end;
  1907. procedure tfiledef.deref;
  1908. begin
  1909. inherited deref;
  1910. if filetyp=ft_typed then
  1911. typedfiledef:=tdef(typedfiledefderef.resolve);
  1912. end;
  1913. procedure tfiledef.setsize;
  1914. begin
  1915. {$ifdef cpu64bitaddr}
  1916. case filetyp of
  1917. ft_text :
  1918. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1919. savesize:=632{+8}
  1920. else
  1921. savesize:=628{+8};
  1922. ft_typed,
  1923. ft_untyped :
  1924. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1925. savesize:=372
  1926. else
  1927. savesize:=368;
  1928. end;
  1929. {$endif cpu64bitaddr}
  1930. {$ifdef cpu32bitaddr}
  1931. case filetyp of
  1932. ft_text :
  1933. savesize:=592{+4};
  1934. ft_typed,
  1935. ft_untyped :
  1936. savesize:=332;
  1937. end;
  1938. {$endif cpu32bitaddr}
  1939. {$ifdef cpu8bitaddr}
  1940. case filetyp of
  1941. ft_text :
  1942. savesize:=127;
  1943. ft_typed,
  1944. ft_untyped :
  1945. savesize:=127;
  1946. end;
  1947. {$endif cpu8bitaddr}
  1948. end;
  1949. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  1950. begin
  1951. inherited ppuwrite(ppufile);
  1952. ppufile.putbyte(byte(filetyp));
  1953. if filetyp=ft_typed then
  1954. ppufile.putderef(typedfiledefderef);
  1955. ppufile.writeentry(ibfiledef);
  1956. end;
  1957. function tfiledef.GetTypeName : string;
  1958. begin
  1959. case filetyp of
  1960. ft_untyped:
  1961. GetTypeName:='File';
  1962. ft_typed:
  1963. GetTypeName:='File Of '+typedfiledef.typename;
  1964. ft_text:
  1965. GetTypeName:='Text'
  1966. end;
  1967. end;
  1968. function tfiledef.getmangledparaname : string;
  1969. begin
  1970. case filetyp of
  1971. ft_untyped:
  1972. getmangledparaname:='FILE';
  1973. ft_typed:
  1974. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  1975. ft_text:
  1976. getmangledparaname:='TEXT'
  1977. end;
  1978. end;
  1979. {****************************************************************************
  1980. TVARIANTDEF
  1981. ****************************************************************************}
  1982. constructor tvariantdef.create(v : tvarianttype);
  1983. begin
  1984. inherited create(variantdef);
  1985. varianttype:=v;
  1986. setsize;
  1987. end;
  1988. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  1989. begin
  1990. inherited ppuload(variantdef,ppufile);
  1991. varianttype:=tvarianttype(ppufile.getbyte);
  1992. setsize;
  1993. end;
  1994. function tvariantdef.getcopy : tstoreddef;
  1995. begin
  1996. result:=tvariantdef.create(varianttype);
  1997. end;
  1998. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  1999. begin
  2000. inherited ppuwrite(ppufile);
  2001. ppufile.putbyte(byte(varianttype));
  2002. ppufile.writeentry(ibvariantdef);
  2003. end;
  2004. function tvariantdef.getvardef : longint;
  2005. begin
  2006. Result:=varVariant;
  2007. end;
  2008. procedure tvariantdef.setsize;
  2009. begin
  2010. {$ifdef cpu64bitaddr}
  2011. savesize:=24;
  2012. {$else cpu64bitaddr}
  2013. savesize:=16;
  2014. {$endif cpu64bitaddr}
  2015. end;
  2016. function tvariantdef.GetTypeName : string;
  2017. begin
  2018. case varianttype of
  2019. vt_normalvariant:
  2020. GetTypeName:='Variant';
  2021. vt_olevariant:
  2022. GetTypeName:='OleVariant';
  2023. end;
  2024. end;
  2025. function tvariantdef.needs_inittable : boolean;
  2026. begin
  2027. needs_inittable:=true;
  2028. end;
  2029. function tvariantdef.is_publishable : boolean;
  2030. begin
  2031. is_publishable:=true;
  2032. end;
  2033. {****************************************************************************
  2034. TABSTRACtpointerdef
  2035. ****************************************************************************}
  2036. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  2037. begin
  2038. inherited create(dt);
  2039. pointeddef:=def;
  2040. savesize:=sizeof(pint);
  2041. end;
  2042. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2043. begin
  2044. inherited ppuload(dt,ppufile);
  2045. ppufile.getderef(pointeddefderef);
  2046. savesize:=sizeof(pint);
  2047. end;
  2048. procedure tabstractpointerdef.buildderef;
  2049. begin
  2050. inherited buildderef;
  2051. pointeddefderef.build(pointeddef);
  2052. end;
  2053. procedure tabstractpointerdef.deref;
  2054. begin
  2055. inherited deref;
  2056. pointeddef:=tdef(pointeddefderef.resolve);
  2057. end;
  2058. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2059. begin
  2060. inherited ppuwrite(ppufile);
  2061. ppufile.putderef(pointeddefderef);
  2062. end;
  2063. {****************************************************************************
  2064. tpointerdef
  2065. ****************************************************************************}
  2066. constructor tpointerdef.create(def:tdef);
  2067. begin
  2068. inherited create(pointerdef,def);
  2069. is_far:=false;
  2070. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2071. end;
  2072. constructor tpointerdef.createfar(def:tdef);
  2073. begin
  2074. inherited create(pointerdef,def);
  2075. is_far:=true;
  2076. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2077. end;
  2078. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  2079. begin
  2080. inherited ppuload(pointerdef,ppufile);
  2081. is_far:=(ppufile.getbyte<>0);
  2082. has_pointer_math:=(ppufile.getbyte<>0);
  2083. end;
  2084. function tpointerdef.getcopy : tstoreddef;
  2085. begin
  2086. { don't use direct pointeddef if it is a forwarddef because in other case
  2087. one of them will be destroyed on forward type resolve and the second will
  2088. point to garbage }
  2089. if pointeddef.typ=forwarddef then
  2090. result:=tpointerdef.create(tforwarddef(pointeddef).getcopy)
  2091. else
  2092. result:=tpointerdef.create(pointeddef);
  2093. tpointerdef(result).is_far:=is_far;
  2094. tpointerdef(result).has_pointer_math:=has_pointer_math;
  2095. tpointerdef(result).savesize:=savesize;
  2096. end;
  2097. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2098. begin
  2099. inherited ppuwrite(ppufile);
  2100. ppufile.putbyte(byte(is_far));
  2101. ppufile.putbyte(byte(has_pointer_math));
  2102. ppufile.writeentry(ibpointerdef);
  2103. end;
  2104. function tpointerdef.GetTypeName : string;
  2105. begin
  2106. if is_far then
  2107. GetTypeName:='^'+pointeddef.typename+';far'
  2108. else
  2109. GetTypeName:='^'+pointeddef.typename;
  2110. end;
  2111. {****************************************************************************
  2112. TCLASSREFDEF
  2113. ****************************************************************************}
  2114. constructor tclassrefdef.create(def:tdef);
  2115. begin
  2116. inherited create(classrefdef,def);
  2117. end;
  2118. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  2119. begin
  2120. inherited ppuload(classrefdef,ppufile);
  2121. end;
  2122. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  2123. begin
  2124. inherited ppuwrite(ppufile);
  2125. ppufile.writeentry(ibclassrefdef);
  2126. end;
  2127. function tclassrefdef.getcopy:tstoreddef;
  2128. begin
  2129. if pointeddef.typ=forwarddef then
  2130. result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy)
  2131. else
  2132. result:=tclassrefdef.create(pointeddef);
  2133. tclassrefdef(result).savesize:=savesize;
  2134. end;
  2135. function tclassrefdef.GetTypeName : string;
  2136. begin
  2137. GetTypeName:='Class Of '+pointeddef.typename;
  2138. end;
  2139. function tclassrefdef.is_publishable : boolean;
  2140. begin
  2141. result:=true;
  2142. end;
  2143. function tclassrefdef.rtti_mangledname(rt: trttitype): string;
  2144. begin
  2145. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  2146. result:=inherited rtti_mangledname(rt)
  2147. else
  2148. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  2149. end;
  2150. procedure tclassrefdef.register_created_object_type;
  2151. begin
  2152. tobjectdef(pointeddef).register_created_classref_type;
  2153. end;
  2154. {***************************************************************************
  2155. TSETDEF
  2156. ***************************************************************************}
  2157. constructor tsetdef.create(def:tdef;low, high : asizeint);
  2158. var
  2159. setallocbits: aint;
  2160. packedsavesize: aint;
  2161. begin
  2162. inherited create(setdef);
  2163. elementdef:=def;
  2164. setmax:=high;
  2165. if (current_settings.setalloc=0) then
  2166. begin
  2167. setbase:=0;
  2168. if (high<32) then
  2169. savesize:=Sizeof(longint)
  2170. else if (high<256) then
  2171. savesize:=32
  2172. else
  2173. savesize:=(high+7) div 8
  2174. end
  2175. else
  2176. begin
  2177. setallocbits:=current_settings.setalloc*8;
  2178. setbase:=low and not(setallocbits-1);
  2179. packedsavesize:=current_settings.setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  2180. savesize:=packedsavesize;
  2181. if savesize=3 then
  2182. savesize:=4;
  2183. end;
  2184. end;
  2185. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2186. begin
  2187. inherited ppuload(setdef,ppufile);
  2188. ppufile.getderef(elementdefderef);
  2189. savesize:=ppufile.getaint;
  2190. setbase:=ppufile.getaint;
  2191. setmax:=ppufile.getaint;
  2192. end;
  2193. function tsetdef.getcopy : tstoreddef;
  2194. begin
  2195. result:=tsetdef.create(elementdef,setbase,setmax);
  2196. { the copy might have been created with a different setalloc setting }
  2197. tsetdef(result).savesize:=savesize;
  2198. end;
  2199. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2200. begin
  2201. inherited ppuwrite(ppufile);
  2202. ppufile.putderef(elementdefderef);
  2203. ppufile.putaint(savesize);
  2204. ppufile.putaint(setbase);
  2205. ppufile.putaint(setmax);
  2206. ppufile.writeentry(ibsetdef);
  2207. end;
  2208. procedure tsetdef.buildderef;
  2209. begin
  2210. inherited buildderef;
  2211. elementdefderef.build(elementdef);
  2212. end;
  2213. procedure tsetdef.deref;
  2214. begin
  2215. inherited deref;
  2216. elementdef:=tdef(elementdefderef.resolve);
  2217. end;
  2218. function tsetdef.is_publishable : boolean;
  2219. begin
  2220. is_publishable:=savesize in [1,2,4];
  2221. end;
  2222. function tsetdef.GetTypeName : string;
  2223. begin
  2224. if assigned(elementdef) then
  2225. GetTypeName:='Set Of '+elementdef.typename
  2226. else
  2227. GetTypeName:='Empty Set';
  2228. end;
  2229. {***************************************************************************
  2230. TFORMALDEF
  2231. ***************************************************************************}
  2232. constructor tformaldef.create(Atyped:boolean);
  2233. begin
  2234. inherited create(formaldef);
  2235. typed:=Atyped;
  2236. savesize:=0;
  2237. end;
  2238. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2239. begin
  2240. inherited ppuload(formaldef,ppufile);
  2241. typed:=boolean(ppufile.getbyte);
  2242. savesize:=0;
  2243. end;
  2244. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2245. begin
  2246. inherited ppuwrite(ppufile);
  2247. ppufile.putbyte(byte(typed));
  2248. ppufile.writeentry(ibformaldef);
  2249. end;
  2250. function tformaldef.GetTypeName : string;
  2251. begin
  2252. if typed then
  2253. GetTypeName:='<Typed formal type>'
  2254. else
  2255. GetTypeName:='<Formal type>';
  2256. end;
  2257. {***************************************************************************
  2258. TARRAYDEF
  2259. ***************************************************************************}
  2260. constructor tarraydef.create(l,h:asizeint;def:tdef);
  2261. begin
  2262. inherited create(arraydef);
  2263. lowrange:=l;
  2264. highrange:=h;
  2265. rangedef:=def;
  2266. _elementdef:=nil;
  2267. arrayoptions:=[];
  2268. symtable:=tarraysymtable.create(self);
  2269. end;
  2270. destructor tarraydef.destroy;
  2271. begin
  2272. symtable.free;
  2273. symtable:=nil;
  2274. inherited;
  2275. end;
  2276. constructor tarraydef.create_from_pointer(def:tdef);
  2277. begin
  2278. { use -1 so that the elecount will not overflow }
  2279. self.create(0,high(asizeint)-1,s32inttype);
  2280. arrayoptions:=[ado_IsConvertedPointer];
  2281. setelementdef(def);
  2282. end;
  2283. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2284. begin
  2285. inherited ppuload(arraydef,ppufile);
  2286. { the addresses are calculated later }
  2287. ppufile.getderef(_elementdefderef);
  2288. ppufile.getderef(rangedefderef);
  2289. lowrange:=ppufile.getaint;
  2290. highrange:=ppufile.getaint;
  2291. ppufile.getsmallset(arrayoptions);
  2292. symtable:=tarraysymtable.create(self);
  2293. tarraysymtable(symtable).ppuload(ppufile)
  2294. end;
  2295. function tarraydef.getcopy : tstoreddef;
  2296. begin
  2297. result:=tarraydef.create(lowrange,highrange,rangedef);
  2298. tarraydef(result).arrayoptions:=arrayoptions;
  2299. tarraydef(result)._elementdef:=_elementdef;
  2300. end;
  2301. procedure tarraydef.buildderef;
  2302. begin
  2303. inherited buildderef;
  2304. tarraysymtable(symtable).buildderef;
  2305. _elementdefderef.build(_elementdef);
  2306. rangedefderef.build(rangedef);
  2307. end;
  2308. procedure tarraydef.deref;
  2309. begin
  2310. inherited deref;
  2311. tarraysymtable(symtable).deref;
  2312. _elementdef:=tdef(_elementdefderef.resolve);
  2313. rangedef:=tdef(rangedefderef.resolve);
  2314. end;
  2315. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2316. begin
  2317. inherited ppuwrite(ppufile);
  2318. ppufile.putderef(_elementdefderef);
  2319. ppufile.putderef(rangedefderef);
  2320. ppufile.putaint(lowrange);
  2321. ppufile.putaint(highrange);
  2322. ppufile.putsmallset(arrayoptions);
  2323. ppufile.writeentry(ibarraydef);
  2324. tarraysymtable(symtable).ppuwrite(ppufile);
  2325. end;
  2326. function tarraydef.elesize : asizeint;
  2327. begin
  2328. if (ado_IsBitPacked in arrayoptions) then
  2329. internalerror(2006080101);
  2330. if assigned(_elementdef) then
  2331. result:=_elementdef.size
  2332. else
  2333. result:=0;
  2334. end;
  2335. function tarraydef.elepackedbitsize : asizeint;
  2336. begin
  2337. if not(ado_IsBitPacked in arrayoptions) then
  2338. internalerror(2006080102);
  2339. if assigned(_elementdef) then
  2340. result:=_elementdef.packedbitsize
  2341. else
  2342. result:=0;
  2343. end;
  2344. function tarraydef.elecount : asizeuint;
  2345. var
  2346. qhigh,qlow : qword;
  2347. begin
  2348. if ado_IsDynamicArray in arrayoptions then
  2349. begin
  2350. result:=0;
  2351. exit;
  2352. end;
  2353. if (highrange>0) and (lowrange<0) then
  2354. begin
  2355. qhigh:=highrange;
  2356. qlow:=qword(-lowrange);
  2357. { prevent overflow, return 0 to indicate overflow }
  2358. if qhigh+qlow>qword(high(asizeint)-1) then
  2359. result:=0
  2360. else
  2361. result:=qhigh+qlow+1;
  2362. end
  2363. else
  2364. result:=int64(highrange)-lowrange+1;
  2365. end;
  2366. function tarraydef.size : asizeint;
  2367. var
  2368. cachedelecount : asizeuint;
  2369. cachedelesize : asizeint;
  2370. begin
  2371. if ado_IsDynamicArray in arrayoptions then
  2372. begin
  2373. size:=sizeof(pint);
  2374. exit;
  2375. end;
  2376. { Tarraydef.size may never be called for an open array! }
  2377. if highrange<lowrange then
  2378. internalerror(99080501);
  2379. if not (ado_IsBitPacked in arrayoptions) then
  2380. cachedelesize:=elesize
  2381. else
  2382. cachedelesize := elepackedbitsize;
  2383. cachedelecount:=elecount;
  2384. if (cachedelesize = 0) then
  2385. begin
  2386. size := 0;
  2387. exit;
  2388. end;
  2389. if (cachedelecount = 0) then
  2390. begin
  2391. size := -1;
  2392. exit;
  2393. end;
  2394. { prevent overflow, return -1 to indicate overflow }
  2395. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  2396. if (cachedelecount > asizeuint(high(asizeint))) or
  2397. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  2398. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  2399. accessing the array, see ncgmem (PFV) }
  2400. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  2401. begin
  2402. result:=-1;
  2403. exit;
  2404. end;
  2405. result:=cachedelesize*asizeint(cachedelecount);
  2406. if (ado_IsBitPacked in arrayoptions) then
  2407. { can't just add 7 and divide by 8, because that may overflow }
  2408. result:=result div 8 + ord((result mod 8)<>0);
  2409. end;
  2410. procedure tarraydef.setelementdef(def:tdef);
  2411. begin
  2412. _elementdef:=def;
  2413. if not(
  2414. (ado_IsDynamicArray in arrayoptions) or
  2415. (ado_IsConvertedPointer in arrayoptions) or
  2416. (highrange<lowrange)
  2417. ) and
  2418. (size=-1) then
  2419. Message(sym_e_segment_too_large);
  2420. end;
  2421. function tarraydef.alignment : shortint;
  2422. begin
  2423. { alignment of dyn. arrays doesn't depend on the element size }
  2424. if (ado_IsDynamicArray in arrayoptions) then
  2425. alignment:=size_2_align(sizeof(pint))
  2426. { alignment is the alignment of the elements }
  2427. else if (elementdef.typ in [arraydef,recorddef,orddef,enumdef,floatdef]) or
  2428. ((elementdef.typ=objectdef) and
  2429. is_object(elementdef)) then
  2430. alignment:=elementdef.alignment
  2431. { alignment is the size of the elements }
  2432. else if not (ado_IsBitPacked in arrayoptions) then
  2433. alignment:=size_2_align(elesize)
  2434. else
  2435. alignment:=packedbitsloadsize(elepackedbitsize);
  2436. end;
  2437. function tarraydef.needs_inittable : boolean;
  2438. begin
  2439. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  2440. end;
  2441. function tarraydef.GetTypeName : string;
  2442. begin
  2443. if (ado_IsConstString in arrayoptions) then
  2444. result:='Constant String'
  2445. else if (ado_isarrayofconst in arrayoptions) or
  2446. (ado_isConstructor in arrayoptions) then
  2447. begin
  2448. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  2449. GetTypeName:='Array Of Const'
  2450. else
  2451. GetTypeName:='{Array Of Const/Constant Open} Array of '+elementdef.typename;
  2452. end
  2453. else if (ado_IsDynamicArray in arrayoptions) then
  2454. GetTypeName:='{Dynamic} Array Of '+elementdef.typename
  2455. else if ((highrange=-1) and (lowrange=0)) then
  2456. GetTypeName:='{Open} Array Of '+elementdef.typename
  2457. else
  2458. begin
  2459. result := '';
  2460. if (ado_IsBitPacked in arrayoptions) then
  2461. result:='BitPacked ';
  2462. if rangedef.typ=enumdef then
  2463. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2464. else
  2465. result:=result+'Array['+tostr(lowrange)+'..'+
  2466. tostr(highrange)+'] Of '+elementdef.typename
  2467. end;
  2468. end;
  2469. function tarraydef.getmangledparaname : string;
  2470. begin
  2471. if ado_isarrayofconst in arrayoptions then
  2472. getmangledparaname:='array_of_const'
  2473. else
  2474. if ((highrange=-1) and (lowrange=0)) then
  2475. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2476. else
  2477. internalerror(200204176);
  2478. end;
  2479. function tarraydef.is_publishable : boolean;
  2480. begin
  2481. Result:=ado_IsDynamicArray in arrayoptions;
  2482. end;
  2483. {***************************************************************************
  2484. tabstractrecorddef
  2485. ***************************************************************************}
  2486. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp);
  2487. begin
  2488. inherited create(dt);
  2489. objname:=stringdup(upper(n));
  2490. objrealname:=stringdup(n);
  2491. objectoptions:=[];
  2492. if assigned(current_module.namespace) then
  2493. begin
  2494. import_lib:=stringdup(current_module.namespace^);
  2495. replace(import_lib^,'.','/');
  2496. end;
  2497. end;
  2498. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2499. begin
  2500. inherited ppuload(dt,ppufile);
  2501. objrealname:=stringdup(ppufile.getstring);
  2502. objname:=stringdup(upper(objrealname^));
  2503. import_lib:=stringdup(ppufile.getstring);
  2504. { only used for external C++ classes and Java classes/records }
  2505. if (import_lib^='') then
  2506. stringdispose(import_lib);
  2507. ppufile.getsmallset(objectoptions);
  2508. end;
  2509. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  2510. begin
  2511. inherited ppuwrite(ppufile);
  2512. ppufile.putstring(objrealname^);
  2513. if assigned(import_lib) then
  2514. ppufile.putstring(import_lib^)
  2515. else
  2516. ppufile.putstring('');
  2517. ppufile.putsmallset(objectoptions);
  2518. end;
  2519. destructor tabstractrecorddef.destroy;
  2520. begin
  2521. stringdispose(objname);
  2522. stringdispose(objrealname);
  2523. stringdispose(import_lib);
  2524. tcinitcode.free;
  2525. inherited destroy;
  2526. end;
  2527. procedure tabstractrecorddef.check_forwards;
  2528. begin
  2529. tstoredsymtable(symtable).check_forwards;
  2530. end;
  2531. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  2532. var
  2533. i: longint;
  2534. sym: tsym;
  2535. begin
  2536. for i:=0 to symtable.SymList.Count-1 do
  2537. begin
  2538. sym:=tsym(symtable.SymList[i]);
  2539. if sym.typ=procsym then
  2540. begin
  2541. result:=tprocsym(sym).find_procdef_bytype(pt);
  2542. if assigned(result) then
  2543. exit;
  2544. end;
  2545. end;
  2546. result:=nil;
  2547. end;
  2548. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  2549. begin
  2550. if t=gs_record then
  2551. GetSymtable:=symtable
  2552. else
  2553. GetSymtable:=nil;
  2554. end;
  2555. function tabstractrecorddef.is_packed:boolean;
  2556. begin
  2557. result:=tabstractrecordsymtable(symtable).is_packed;
  2558. end;
  2559. function tabstractrecorddef.RttiName: string;
  2560. begin
  2561. Result:=OwnerHierarchyName+objrealname^;
  2562. end;
  2563. function tabstractrecorddef.search_enumerator_get: tprocdef;
  2564. var
  2565. sym : tsym;
  2566. i : integer;
  2567. pd : tprocdef;
  2568. hashedid : THashedIDString;
  2569. begin
  2570. result:=nil;
  2571. hashedid.id:='GETENUMERATOR';
  2572. sym:=tsym(symtable.FindWithHash(hashedid));
  2573. if assigned(sym) and (sym.typ=procsym) then
  2574. begin
  2575. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  2576. begin
  2577. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2578. if (pd.proctypeoption = potype_function) and
  2579. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  2580. (pd.visibility >= vis_public) then
  2581. begin
  2582. result:=pd;
  2583. exit;
  2584. end;
  2585. end;
  2586. end;
  2587. end;
  2588. function tabstractrecorddef.search_enumerator_move: tprocdef;
  2589. var
  2590. sym : tsym;
  2591. i : integer;
  2592. pd : tprocdef;
  2593. hashedid : THashedIDString;
  2594. begin
  2595. result:=nil;
  2596. // first search for po_enumerator_movenext method modifier
  2597. // then search for public function MoveNext: Boolean
  2598. for i:=0 to symtable.SymList.Count-1 do
  2599. begin
  2600. sym:=TSym(symtable.SymList[i]);
  2601. if (sym.typ=procsym) then
  2602. begin
  2603. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  2604. if assigned(pd) then
  2605. begin
  2606. result:=pd;
  2607. exit;
  2608. end;
  2609. end;
  2610. end;
  2611. hashedid.id:='MOVENEXT';
  2612. sym:=tsym(symtable.FindWithHash(hashedid));
  2613. if assigned(sym) and (sym.typ=procsym) then
  2614. begin
  2615. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  2616. begin
  2617. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2618. if (pd.proctypeoption = potype_function) and
  2619. is_boolean(pd.returndef) and
  2620. (pd.minparacount = 0) and
  2621. (pd.visibility >= vis_public) then
  2622. begin
  2623. result:=pd;
  2624. exit;
  2625. end;
  2626. end;
  2627. end;
  2628. end;
  2629. function tabstractrecorddef.search_enumerator_current: tsym;
  2630. var
  2631. sym: tsym;
  2632. i: integer;
  2633. hashedid : THashedIDString;
  2634. begin
  2635. result:=nil;
  2636. // first search for ppo_enumerator_current property modifier
  2637. // then search for public property Current
  2638. for i:=0 to symtable.SymList.Count-1 do
  2639. begin
  2640. sym:=TSym(symtable.SymList[i]);
  2641. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  2642. begin
  2643. result:=sym;
  2644. exit;
  2645. end;
  2646. end;
  2647. hashedid.id:='CURRENT';
  2648. sym:=tsym(symtable.FindWithHash(hashedid));
  2649. if assigned(sym) and (sym.typ=propertysym) and
  2650. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  2651. begin
  2652. result:=sym;
  2653. exit;
  2654. end;
  2655. end;
  2656. function tabstractrecorddef.jvm_full_typename(with_package_name: boolean): string;
  2657. var
  2658. st: tsymtable;
  2659. enclosingobj: tabstractrecorddef;
  2660. begin
  2661. if typ=objectdef then
  2662. result:=tobjectdef(self).objextname^
  2663. else if assigned(typesym) then
  2664. result:=typesym.realname
  2665. { have to generate anonymous nested type in current unit/class/record }
  2666. else
  2667. internalerror(2011032601);
  2668. st:=owner;
  2669. while assigned(st) and
  2670. (st.symtabletype in [objectsymtable,recordsymtable]) do
  2671. begin
  2672. { nested classes are named as "OuterClass$InnerClass" }
  2673. enclosingobj:=tabstractrecorddef(st.defowner);
  2674. if enclosingobj.typ=objectdef then
  2675. result:=tobjectdef(enclosingobj).objextname^+'$'+result
  2676. else if assigned(enclosingobj.typesym) then
  2677. result:=enclosingobj.typesym.realname+'$'+result;
  2678. st:=enclosingobj.owner;
  2679. end;
  2680. if with_package_name and
  2681. assigned(import_lib) then
  2682. result:=import_lib^+'/'+result;
  2683. end;
  2684. {***************************************************************************
  2685. trecorddef
  2686. ***************************************************************************}
  2687. constructor trecorddef.create(const n:string; p:TSymtable);
  2688. begin
  2689. inherited create(n,recorddef);
  2690. symtable:=p;
  2691. { we can own the symtable only if nobody else owns a copy so far }
  2692. if symtable.refcount=1 then
  2693. symtable.defowner:=self;
  2694. isunion:=false;
  2695. end;
  2696. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2697. begin
  2698. inherited ppuload(recorddef,ppufile);
  2699. if df_copied_def in defoptions then
  2700. ppufile.getderef(cloneddefderef)
  2701. else
  2702. begin
  2703. symtable:=trecordsymtable.create(objrealname^,0);
  2704. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2705. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2706. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2707. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2708. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  2709. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  2710. trecordsymtable(symtable).ppuload(ppufile);
  2711. { requires usefieldalignment to be set }
  2712. symtable.defowner:=self;
  2713. end;
  2714. isunion:=false;
  2715. end;
  2716. destructor trecorddef.destroy;
  2717. begin
  2718. if assigned(symtable) then
  2719. begin
  2720. symtable.free;
  2721. symtable:=nil;
  2722. end;
  2723. inherited destroy;
  2724. end;
  2725. function trecorddef.getcopy : tstoreddef;
  2726. begin
  2727. result:=trecorddef.create(objrealname^,symtable.getcopy);
  2728. trecorddef(result).isunion:=isunion;
  2729. include(trecorddef(result).defoptions,df_copied_def);
  2730. if assigned(tcinitcode) then
  2731. trecorddef(result).tcinitcode:=tcinitcode.getcopy;
  2732. if assigned(import_lib) then
  2733. trecorddef(result).import_lib:=stringdup(import_lib^);
  2734. end;
  2735. function trecorddef.needs_inittable : boolean;
  2736. begin
  2737. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2738. end;
  2739. function trecorddef.is_related(d: tdef): boolean;
  2740. begin
  2741. if d.typ=objectdef then
  2742. d:=find_real_class_definition(tobjectdef(d),false);
  2743. { records are implemented via classes in the JVM target, and are
  2744. all descendents of the java_fpcbaserecordtype class }
  2745. if (target_info.system=system_jvm_java32) and
  2746. ((d=java_jlobject) or
  2747. (d=java_fpcbaserecordtype)) then
  2748. is_related:=true
  2749. else
  2750. is_related:=false;
  2751. end;
  2752. procedure trecorddef.buildderef;
  2753. begin
  2754. inherited buildderef;
  2755. if df_copied_def in defoptions then
  2756. cloneddefderef.build(symtable.defowner)
  2757. else
  2758. tstoredsymtable(symtable).buildderef;
  2759. end;
  2760. procedure trecorddef.deref;
  2761. begin
  2762. inherited deref;
  2763. { now dereference the definitions }
  2764. if df_copied_def in defoptions then
  2765. begin
  2766. cloneddef:=trecorddef(cloneddefderef.resolve);
  2767. symtable:=cloneddef.symtable.getcopy;
  2768. end
  2769. else
  2770. tstoredsymtable(symtable).deref;
  2771. { assign TGUID? load only from system unit }
  2772. if not(assigned(rec_tguid)) and
  2773. (upper(typename)='TGUID') and
  2774. assigned(owner) and
  2775. assigned(owner.name) and
  2776. (owner.name^='SYSTEM') then
  2777. rec_tguid:=self;
  2778. { assign JMP_BUF? load only from system unit }
  2779. if not(assigned(rec_jmp_buf)) and
  2780. (upper(typename)='JMP_BUF') and
  2781. assigned(owner) and
  2782. assigned(owner.name) and
  2783. (owner.name^='SYSTEM') then
  2784. rec_jmp_buf:=self;
  2785. end;
  2786. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2787. begin
  2788. inherited ppuwrite(ppufile);
  2789. if df_copied_def in defoptions then
  2790. ppufile.putderef(cloneddefderef)
  2791. else
  2792. begin
  2793. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  2794. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  2795. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  2796. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  2797. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  2798. ppufile.putword(trecordsymtable(symtable).paddingsize);
  2799. end;
  2800. ppufile.writeentry(ibrecorddef);
  2801. if not(df_copied_def in defoptions) then
  2802. trecordsymtable(symtable).ppuwrite(ppufile);
  2803. end;
  2804. function trecorddef.size:asizeint;
  2805. begin
  2806. result:=trecordsymtable(symtable).datasize;
  2807. end;
  2808. function trecorddef.alignment:shortint;
  2809. begin
  2810. alignment:=trecordsymtable(symtable).recordalignment;
  2811. end;
  2812. function trecorddef.padalignment:shortint;
  2813. begin
  2814. padalignment := trecordsymtable(symtable).padalignment;
  2815. end;
  2816. function trecorddef.GetTypeName : string;
  2817. begin
  2818. GetTypeName:='<record type>'
  2819. end;
  2820. {***************************************************************************
  2821. TABSTRACTPROCDEF
  2822. ***************************************************************************}
  2823. constructor tabstractprocdef.create(dt:tdeftyp;level:byte);
  2824. begin
  2825. inherited create(dt);
  2826. parast:=tparasymtable.create(self,level);
  2827. paras:=nil;
  2828. minparacount:=0;
  2829. maxparacount:=0;
  2830. proctypeoption:=potype_none;
  2831. proccalloption:=pocall_none;
  2832. procoptions:=[];
  2833. returndef:=voidtype;
  2834. savesize:=sizeof(pint);
  2835. callerargareasize:=0;
  2836. calleeargareasize:=0;
  2837. has_paraloc_info:=callnoside;
  2838. funcretloc[callerside].init;
  2839. funcretloc[calleeside].init;
  2840. check_mark_as_nested;
  2841. end;
  2842. destructor tabstractprocdef.destroy;
  2843. begin
  2844. if assigned(paras) then
  2845. begin
  2846. {$ifdef MEMDEBUG}
  2847. memprocpara.start;
  2848. {$endif MEMDEBUG}
  2849. paras.free;
  2850. paras:=nil;
  2851. {$ifdef MEMDEBUG}
  2852. memprocpara.stop;
  2853. {$endif MEMDEBUG}
  2854. end;
  2855. if assigned(parast) then
  2856. begin
  2857. {$ifdef MEMDEBUG}
  2858. memprocparast.start;
  2859. {$endif MEMDEBUG}
  2860. parast.free;
  2861. parast:=nil;
  2862. {$ifdef MEMDEBUG}
  2863. memprocparast.stop;
  2864. {$endif MEMDEBUG}
  2865. end;
  2866. funcretloc[callerside].done;
  2867. funcretloc[calleeside].done;
  2868. inherited destroy;
  2869. end;
  2870. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  2871. begin
  2872. if (tsym(p).typ<>paravarsym) then
  2873. exit;
  2874. inc(plongint(arg)^);
  2875. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  2876. begin
  2877. if not assigned(tparavarsym(p).defaultconstsym) then
  2878. inc(minparacount);
  2879. inc(maxparacount);
  2880. end;
  2881. end;
  2882. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  2883. begin
  2884. if (tsym(p).typ<>paravarsym) then
  2885. exit;
  2886. paras.add(p);
  2887. end;
  2888. procedure tabstractprocdef.calcparas;
  2889. var
  2890. paracount : longint;
  2891. begin
  2892. { This can already be assigned when
  2893. we need to reresolve this unit (PFV) }
  2894. if assigned(paras) then
  2895. paras.free;
  2896. paras:=tparalist.create(false);
  2897. paracount:=0;
  2898. minparacount:=0;
  2899. maxparacount:=0;
  2900. parast.SymList.ForEachCall(@count_para,@paracount);
  2901. paras.capacity:=paracount;
  2902. { Insert parameters in table }
  2903. parast.SymList.ForEachCall(@insert_para,nil);
  2904. { Order parameters }
  2905. paras.sortparas;
  2906. end;
  2907. procedure tabstractprocdef.buildderef;
  2908. begin
  2909. { released procdef? }
  2910. if not assigned(parast) then
  2911. exit;
  2912. inherited buildderef;
  2913. returndefderef.build(returndef);
  2914. { parast }
  2915. tparasymtable(parast).buildderef;
  2916. end;
  2917. procedure tabstractprocdef.deref;
  2918. begin
  2919. inherited deref;
  2920. returndef:=tdef(returndefderef.resolve);
  2921. { parast }
  2922. tparasymtable(parast).deref;
  2923. { recalculated parameters }
  2924. calcparas;
  2925. end;
  2926. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2927. begin
  2928. inherited ppuload(dt,ppufile);
  2929. parast:=nil;
  2930. Paras:=nil;
  2931. minparacount:=0;
  2932. maxparacount:=0;
  2933. ppufile.getderef(returndefderef);
  2934. { TODO: remove fpu_used loading}
  2935. ppufile.getbyte;
  2936. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2937. proccalloption:=tproccalloption(ppufile.getbyte);
  2938. ppufile.getnormalset(procoptions);
  2939. funcretloc[callerside].init;
  2940. if po_explicitparaloc in procoptions then
  2941. funcretloc[callerside].ppuload(ppufile);
  2942. savesize:=sizeof(pint);
  2943. if (po_explicitparaloc in procoptions) then
  2944. has_paraloc_info:=callerside;
  2945. end;
  2946. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  2947. var
  2948. oldintfcrc : boolean;
  2949. begin
  2950. { released procdef? }
  2951. if not assigned(parast) then
  2952. exit;
  2953. inherited ppuwrite(ppufile);
  2954. ppufile.putderef(returndefderef);
  2955. oldintfcrc:=ppufile.do_interface_crc;
  2956. ppufile.do_interface_crc:=false;
  2957. ppufile.putbyte(0);
  2958. ppufile.putbyte(ord(proctypeoption));
  2959. ppufile.putbyte(ord(proccalloption));
  2960. ppufile.putnormalset(procoptions);
  2961. ppufile.do_interface_crc:=oldintfcrc;
  2962. if (po_explicitparaloc in procoptions) then
  2963. funcretloc[callerside].ppuwrite(ppufile);
  2964. end;
  2965. function tabstractprocdef.typename_paras(pno: tprocnameoptions) : ansistring;
  2966. var
  2967. hs,s : ansistring;
  2968. hp : TParavarsym;
  2969. hpc : tconstsym;
  2970. first : boolean;
  2971. i : integer;
  2972. begin
  2973. s:='';
  2974. first:=true;
  2975. for i:=0 to paras.count-1 do
  2976. begin
  2977. hp:=tparavarsym(paras[i]);
  2978. if not(vo_is_hidden_para in hp.varoptions) or
  2979. (pno_showhidden in pno) then
  2980. begin
  2981. if first then
  2982. begin
  2983. s:=s+'(';
  2984. first:=false;
  2985. end
  2986. else
  2987. s:=s+';';
  2988. if vo_is_hidden_para in hp.varoptions then
  2989. s:=s+'<';
  2990. case hp.varspez of
  2991. vs_var :
  2992. s:=s+'var ';
  2993. vs_const :
  2994. s:=s+'const ';
  2995. vs_out :
  2996. s:=s+'out ';
  2997. vs_constref :
  2998. s:=s+'constref ';
  2999. end;
  3000. if (pno_paranames in pno) then
  3001. s:=s+hp.realname+':';
  3002. if hp.univpara then
  3003. s:=s+'univ ';
  3004. if assigned(hp.vardef.typesym) then
  3005. begin
  3006. hs:=hp.vardef.typesym.realname;
  3007. if hs[1]<>'$' then
  3008. s:=s+hp.vardef.OwnerHierarchyName+hs
  3009. else
  3010. s:=s+hp.vardef.GetTypeName;
  3011. end
  3012. else
  3013. s:=s+hp.vardef.GetTypeName;
  3014. { default value }
  3015. if assigned(hp.defaultconstsym) then
  3016. begin
  3017. hpc:=tconstsym(hp.defaultconstsym);
  3018. hs:='';
  3019. case hpc.consttyp of
  3020. conststring,
  3021. constresourcestring :
  3022. begin
  3023. If hpc.value.len>0 then
  3024. begin
  3025. setLength(hs,hpc.value.len);
  3026. { don't write past the end of hs if the constant
  3027. is > 255 chars }
  3028. move(hpc.value.valueptr^,hs[1],length(hs));
  3029. { make sure that constant strings with newline chars
  3030. don't create a linebreak in the assembler code,
  3031. since comments are line-based. Also remove nulls
  3032. because the comments are written as a pchar. }
  3033. ReplaceCase(hs,#0,'.');
  3034. ReplaceCase(hs,#10,'.');
  3035. ReplaceCase(hs,#13,'.');
  3036. end;
  3037. end;
  3038. constreal :
  3039. str(pbestreal(hpc.value.valueptr)^,hs);
  3040. constpointer :
  3041. hs:=tostr(hpc.value.valueordptr);
  3042. constord :
  3043. begin
  3044. if is_boolean(hpc.constdef) then
  3045. begin
  3046. if hpc.value.valueord<>0 then
  3047. hs:='TRUE'
  3048. else
  3049. hs:='FALSE';
  3050. end
  3051. else
  3052. hs:=tostr(hpc.value.valueord);
  3053. end;
  3054. constnil :
  3055. hs:='nil';
  3056. constset :
  3057. hs:='<set>';
  3058. end;
  3059. if hs<>'' then
  3060. s:=s+'="'+hs+'"';
  3061. end;
  3062. if vo_is_hidden_para in hp.varoptions then
  3063. s:=s+'>';
  3064. end;
  3065. end;
  3066. if not first then
  3067. s:=s+')';
  3068. if (po_varargs in procoptions) then
  3069. s:=s+';VarArgs';
  3070. typename_paras:=s;
  3071. end;
  3072. function tabstractprocdef.is_methodpointer:boolean;
  3073. begin
  3074. result:=false;
  3075. end;
  3076. function tabstractprocdef.is_addressonly:boolean;
  3077. begin
  3078. result:=true;
  3079. end;
  3080. function tabstractprocdef.no_self_node: boolean;
  3081. begin
  3082. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  3083. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  3084. end;
  3085. procedure tabstractprocdef.check_mark_as_nested;
  3086. begin
  3087. { nested procvars require that nested functions use the Delphi-style
  3088. nested procedure calling convention }
  3089. if (parast.symtablelevel>normal_function_level) and
  3090. (m_nested_procvars in current_settings.modeswitches) then
  3091. include(procoptions,po_delphi_nested_cc);
  3092. end;
  3093. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  3094. begin
  3095. if (side in [callerside,callbothsides]) and
  3096. not(has_paraloc_info in [callerside,callbothsides]) then
  3097. begin
  3098. callerargareasize:=paramanager.create_paraloc_info(self,callerside);
  3099. if has_paraloc_info in [calleeside,callbothsides] then
  3100. has_paraloc_info:=callbothsides
  3101. else
  3102. has_paraloc_info:=callerside;
  3103. end;
  3104. if (side in [calleeside,callbothsides]) and
  3105. not(has_paraloc_info in [calleeside,callbothsides]) then
  3106. begin
  3107. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside);
  3108. if has_paraloc_info in [callerside,callbothsides] then
  3109. has_paraloc_info:=callbothsides
  3110. else
  3111. has_paraloc_info:=calleeside;
  3112. end;
  3113. end;
  3114. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  3115. var
  3116. p: tparavarsym;
  3117. ploc: PCGParalocation;
  3118. i: longint;
  3119. begin
  3120. result:=false;
  3121. init_paraloc_info(side);
  3122. for i:=0 to parast.SymList.Count-1 do
  3123. if tsym(parast.SymList[i]).typ=paravarsym then
  3124. begin
  3125. p:=tparavarsym(parast.SymList[i]);
  3126. { check if no parameter is located on the stack }
  3127. if is_open_array(p.vardef) or
  3128. is_array_of_const(p.vardef) then
  3129. begin
  3130. result:=true;
  3131. exit;
  3132. end;
  3133. ploc:=p.paraloc[side].location;
  3134. while assigned(ploc) do
  3135. begin
  3136. if (ploc^.loc=LOC_REFERENCE) then
  3137. begin
  3138. result:=true;
  3139. exit
  3140. end;
  3141. ploc:=ploc^.next;
  3142. end;
  3143. end;
  3144. end;
  3145. {***************************************************************************
  3146. TPROCDEF
  3147. ***************************************************************************}
  3148. constructor tprocdef.create(level:byte);
  3149. begin
  3150. inherited create(procdef,level);
  3151. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  3152. _mangledname:=nil;
  3153. fileinfo:=current_filepos;
  3154. extnumber:=$ffff;
  3155. aliasnames:=TCmdStrList.create;
  3156. funcretsym:=nil;
  3157. forwarddef:=true;
  3158. interfacedef:=false;
  3159. hasforward:=false;
  3160. struct := nil;
  3161. import_dll:=nil;
  3162. import_name:=nil;
  3163. import_nr:=0;
  3164. inlininginfo:=nil;
  3165. deprecatedmsg:=nil;
  3166. {$ifdef i386}
  3167. fpu_used:=maxfpuregs;
  3168. {$endif i386}
  3169. interruptvector:=-1;
  3170. end;
  3171. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  3172. var
  3173. i,aliasnamescount : longint;
  3174. level : byte;
  3175. begin
  3176. inherited ppuload(procdef,ppufile);
  3177. if po_has_mangledname in procoptions then
  3178. _mangledname:=stringdup(ppufile.getstring)
  3179. else
  3180. _mangledname:=nil;
  3181. extnumber:=ppufile.getword;
  3182. level:=ppufile.getbyte;
  3183. ppufile.getderef(structderef);
  3184. ppufile.getderef(procsymderef);
  3185. ppufile.getposinfo(fileinfo);
  3186. visibility:=tvisibility(ppufile.getbyte);
  3187. ppufile.getsmallset(symoptions);
  3188. if sp_has_deprecated_msg in symoptions then
  3189. deprecatedmsg:=stringdup(ppufile.getstring)
  3190. else
  3191. deprecatedmsg:=nil;
  3192. {$ifdef powerpc}
  3193. { library symbol for AmigaOS/MorphOS }
  3194. ppufile.getderef(libsymderef);
  3195. {$endif powerpc}
  3196. { import stuff }
  3197. if po_has_importdll in procoptions then
  3198. import_dll:=stringdup(ppufile.getstring)
  3199. else
  3200. import_dll:=nil;
  3201. if po_has_importname in procoptions then
  3202. import_name:=stringdup(ppufile.getstring)
  3203. else
  3204. import_name:=nil;
  3205. import_nr:=ppufile.getword;
  3206. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3207. if target_info.system in systems_interrupt_table then
  3208. interruptvector:=ppufile.getlongint;
  3209. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3210. if (po_msgint in procoptions) then
  3211. messageinf.i:=ppufile.getlongint;
  3212. if (po_msgstr in procoptions) then
  3213. messageinf.str:=stringdup(ppufile.getstring);
  3214. if (po_dispid in procoptions) then
  3215. dispid:=ppufile.getlongint;
  3216. { inline stuff }
  3217. if (po_has_inlininginfo in procoptions) then
  3218. begin
  3219. ppufile.getderef(funcretsymderef);
  3220. new(inlininginfo);
  3221. ppufile.getsmallset(inlininginfo^.flags);
  3222. end
  3223. else
  3224. begin
  3225. inlininginfo:=nil;
  3226. funcretsym:=nil;
  3227. end;
  3228. aliasnames:=TCmdStrList.create;
  3229. { count alias names }
  3230. aliasnamescount:=ppufile.getbyte;
  3231. for i:=1 to aliasnamescount do
  3232. aliasnames.insert(ppufile.getstring);
  3233. { load para symtable }
  3234. parast:=tparasymtable.create(self,level);
  3235. tparasymtable(parast).ppuload(ppufile);
  3236. { load local symtable }
  3237. if (po_has_inlininginfo in procoptions) then
  3238. begin
  3239. localst:=tlocalsymtable.create(self,level);
  3240. tlocalsymtable(localst).ppuload(ppufile);
  3241. end
  3242. else
  3243. localst:=nil;
  3244. { inline stuff }
  3245. if (po_has_inlininginfo in procoptions) then
  3246. inlininginfo^.code:=ppuloadnodetree(ppufile);
  3247. { default values for no persistent data }
  3248. if (cs_link_deffile in current_settings.globalswitches) and
  3249. (tf_need_export in target_info.flags) and
  3250. (po_exports in procoptions) then
  3251. deffile.AddExport(mangledname);
  3252. forwarddef:=false;
  3253. interfacedef:=false;
  3254. hasforward:=false;
  3255. { Disable po_has_inlining until the derefimpl is done }
  3256. exclude(procoptions,po_has_inlininginfo);
  3257. {$ifdef i386}
  3258. fpu_used:=maxfpuregs;
  3259. {$endif i386}
  3260. end;
  3261. destructor tprocdef.destroy;
  3262. begin
  3263. aliasnames.free;
  3264. aliasnames:=nil;
  3265. if assigned(localst) and
  3266. (localst.symtabletype<>staticsymtable) then
  3267. begin
  3268. {$ifdef MEMDEBUG}
  3269. memproclocalst.start;
  3270. {$endif MEMDEBUG}
  3271. localst.free;
  3272. localst:=nil;
  3273. {$ifdef MEMDEBUG}
  3274. memproclocalst.start;
  3275. {$endif MEMDEBUG}
  3276. end;
  3277. if assigned(inlininginfo) then
  3278. begin
  3279. {$ifdef MEMDEBUG}
  3280. memprocnodetree.start;
  3281. {$endif MEMDEBUG}
  3282. tnode(inlininginfo^.code).free;
  3283. {$ifdef MEMDEBUG}
  3284. memprocnodetree.start;
  3285. {$endif MEMDEBUG}
  3286. dispose(inlininginfo);
  3287. inlininginfo:=nil;
  3288. end;
  3289. {$ifdef jvm}
  3290. exprasmlist.free;
  3291. {$endif}
  3292. stringdispose(resultname);
  3293. stringdispose(import_dll);
  3294. stringdispose(import_name);
  3295. stringdispose(deprecatedmsg);
  3296. if (po_msgstr in procoptions) then
  3297. stringdispose(messageinf.str);
  3298. if assigned(_mangledname) then
  3299. begin
  3300. {$ifdef MEMDEBUG}
  3301. memmanglednames.start;
  3302. {$endif MEMDEBUG}
  3303. stringdispose(_mangledname);
  3304. {$ifdef MEMDEBUG}
  3305. memmanglednames.stop;
  3306. {$endif MEMDEBUG}
  3307. end;
  3308. inherited destroy;
  3309. end;
  3310. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  3311. var
  3312. oldintfcrc : boolean;
  3313. aliasnamescount : longint;
  3314. item : TCmdStrListItem;
  3315. begin
  3316. { released procdef? }
  3317. if not assigned(parast) then
  3318. exit;
  3319. inherited ppuwrite(ppufile);
  3320. if po_has_mangledname in procoptions then
  3321. ppufile.putstring(_mangledname^);
  3322. ppufile.putword(extnumber);
  3323. ppufile.putbyte(parast.symtablelevel);
  3324. ppufile.putderef(structderef);
  3325. ppufile.putderef(procsymderef);
  3326. ppufile.putposinfo(fileinfo);
  3327. ppufile.putbyte(byte(visibility));
  3328. ppufile.putsmallset(symoptions);
  3329. if sp_has_deprecated_msg in symoptions then
  3330. ppufile.putstring(deprecatedmsg^);
  3331. {$ifdef powerpc}
  3332. { library symbol for AmigaOS/MorphOS }
  3333. ppufile.putderef(libsymderef);
  3334. {$endif powerpc}
  3335. { import }
  3336. if po_has_importdll in procoptions then
  3337. ppufile.putstring(import_dll^);
  3338. if po_has_importname in procoptions then
  3339. ppufile.putstring(import_name^);
  3340. ppufile.putword(import_nr);
  3341. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3342. if target_info.system in systems_interrupt_table then
  3343. ppufile.putlongint(interruptvector);
  3344. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3345. if (po_msgint in procoptions) then
  3346. ppufile.putlongint(messageinf.i);
  3347. if (po_msgstr in procoptions) then
  3348. ppufile.putstring(messageinf.str^);
  3349. if (po_dispid in procoptions) then
  3350. ppufile.putlongint(dispid);
  3351. { inline stuff }
  3352. oldintfcrc:=ppufile.do_crc;
  3353. ppufile.do_crc:=false;
  3354. if (po_has_inlininginfo in procoptions) then
  3355. begin
  3356. ppufile.putderef(funcretsymderef);
  3357. ppufile.putsmallset(inlininginfo^.flags);
  3358. end;
  3359. { count alias names }
  3360. aliasnamescount:=0;
  3361. item:=TCmdStrListItem(aliasnames.first);
  3362. while assigned(item) do
  3363. begin
  3364. inc(aliasnamescount);
  3365. item:=TCmdStrListItem(item.next);
  3366. end;
  3367. if aliasnamescount>255 then
  3368. internalerror(200711021);
  3369. ppufile.putbyte(aliasnamescount);
  3370. item:=TCmdStrListItem(aliasnames.first);
  3371. while assigned(item) do
  3372. begin
  3373. ppufile.putstring(item.str);
  3374. item:=TCmdStrListItem(item.next);
  3375. end;
  3376. ppufile.do_crc:=oldintfcrc;
  3377. { write this entry }
  3378. ppufile.writeentry(ibprocdef);
  3379. { Save the para symtable, this is taken from the interface }
  3380. tparasymtable(parast).ppuwrite(ppufile);
  3381. { save localsymtable for inline procedures or when local
  3382. browser info is requested, this has no influence on the crc }
  3383. if (po_has_inlininginfo in procoptions) then
  3384. begin
  3385. oldintfcrc:=ppufile.do_crc;
  3386. ppufile.do_crc:=false;
  3387. tlocalsymtable(localst).ppuwrite(ppufile);
  3388. ppufile.do_crc:=oldintfcrc;
  3389. end;
  3390. { node tree for inlining }
  3391. oldintfcrc:=ppufile.do_crc;
  3392. ppufile.do_crc:=false;
  3393. if (po_has_inlininginfo in procoptions) then
  3394. ppuwritenodetree(ppufile,inlininginfo^.code);
  3395. ppufile.do_crc:=oldintfcrc;
  3396. end;
  3397. function tprocdef.fullprocname(showhidden:boolean):string;
  3398. var
  3399. pno: tprocnameoptions;
  3400. begin
  3401. pno:=[];
  3402. if showhidden then
  3403. include(pno,pno_showhidden);
  3404. result:=customprocname(pno);
  3405. end;
  3406. function tprocdef.customprocname(pno: tprocnameoptions):ansistring;
  3407. var
  3408. s, rn : ansistring;
  3409. t : ttoken;
  3410. begin
  3411. {$ifdef EXTDEBUG}
  3412. include(pno,pno_showhidden);
  3413. {$endif EXTDEBUG}
  3414. s:='';
  3415. if proctypeoption=potype_operator then
  3416. begin
  3417. for t:=NOTOKEN to last_overloaded do
  3418. if procsym.realname='$'+overloaded_names[t] then
  3419. begin
  3420. s:='operator ';
  3421. if (pno_ownername in pno) and
  3422. assigned(struct) then
  3423. s:=s+struct.RttiName+'.';
  3424. s:=s+arraytokeninfo[t].str+typename_paras(pno);
  3425. break;
  3426. end;
  3427. end
  3428. else
  3429. begin
  3430. if (po_classmethod in procoptions) and
  3431. not(pno_noclassmarker in pno) then
  3432. s:='class ';
  3433. case proctypeoption of
  3434. potype_constructor,
  3435. potype_class_constructor:
  3436. s:=s+'constructor ';
  3437. potype_class_destructor,
  3438. potype_destructor:
  3439. s:=s+'destructor ';
  3440. else
  3441. if (pno_proctypeoption in pno) and
  3442. assigned(returndef) and
  3443. not(is_void(returndef)) then
  3444. s:=s+'function '
  3445. else
  3446. s:=s+'procedure ';
  3447. end;
  3448. if (pno_ownername in pno) and
  3449. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  3450. s:=s+tabstractrecorddef(owner.defowner).RttiName+'.';
  3451. rn:=procsym.realname;
  3452. if (pno_noleadingdollar in pno) and
  3453. (rn[1]='$') then
  3454. delete(rn,1,1);
  3455. s:=s+rn+typename_paras(pno);
  3456. end;
  3457. if not(proctypeoption in [potype_constructor,potype_destructor,
  3458. potype_class_constructor,potype_class_destructor]) and
  3459. assigned(returndef) and
  3460. not(is_void(returndef)) then
  3461. s:=s+':'+returndef.GetTypeName;
  3462. if owner.symtabletype=localsymtable then
  3463. s:=s+' is nested';
  3464. s:=s+';';
  3465. { forced calling convention? }
  3466. if (po_hascallingconvention in procoptions) then
  3467. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  3468. if (po_staticmethod in procoptions) and
  3469. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  3470. s:=s+' Static;';
  3471. customprocname:=s;
  3472. end;
  3473. function tprocdef.is_methodpointer:boolean;
  3474. begin
  3475. { don't check assigned(_class), that's also the case for nested
  3476. procedures inside methods }
  3477. result:=owner.symtabletype=ObjectSymtable;
  3478. end;
  3479. function tprocdef.is_addressonly:boolean;
  3480. begin
  3481. result:=assigned(owner) and
  3482. (owner.symtabletype<>ObjectSymtable) and
  3483. (not(m_nested_procvars in current_settings.modeswitches) or
  3484. not is_nested_pd(self));
  3485. end;
  3486. procedure tprocdef.make_external;
  3487. begin
  3488. include(procoptions,po_external);
  3489. forwarddef:=false;
  3490. end;
  3491. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  3492. begin
  3493. case t of
  3494. gs_local :
  3495. GetSymtable:=localst;
  3496. gs_para :
  3497. GetSymtable:=parast;
  3498. else
  3499. GetSymtable:=nil;
  3500. end;
  3501. end;
  3502. function tprocdef.getcopy: tstoreddef;
  3503. var
  3504. i : tcallercallee;
  3505. j : longint;
  3506. pvs : tparavarsym;
  3507. begin
  3508. result:=tprocdef.create(parast.symtablelevel);
  3509. tprocdef(result).returndef:=returndef;
  3510. tprocdef(result).returndefderef:=returndefderef;
  3511. tprocdef(result).parast:=tparasymtable.create(tprocdef(result),parast.symtablelevel);
  3512. for j:=0 to parast.symlist.count-1 do
  3513. begin
  3514. case tsym(parast.symlist[j]).typ of
  3515. paravarsym:
  3516. begin
  3517. pvs:=tparavarsym(parast.symlist[j]);
  3518. tprocdef(result).parast.insert(tparavarsym.create(
  3519. pvs.realname,pvs.paranr,pvs.varspez,pvs.vardef,pvs.varoptions));
  3520. end;
  3521. else
  3522. internalerror(201160604);
  3523. end;
  3524. end;
  3525. tprocdef(result).savesize:=savesize;
  3526. tprocdef(result).proctypeoption:=proctypeoption;
  3527. tprocdef(result).proccalloption:=proccalloption;
  3528. tprocdef(result).procoptions:=procoptions;
  3529. tprocdef(result).callerargareasize:=callerargareasize;
  3530. tprocdef(result).calleeargareasize:=calleeargareasize;
  3531. tprocdef(result).maxparacount:=maxparacount;
  3532. tprocdef(result).minparacount:=minparacount;
  3533. if po_explicitparaloc in procoptions then
  3534. tprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
  3535. { recalculate parameter info }
  3536. tprocdef(result).has_paraloc_info:=callnoside;
  3537. {$ifdef m68k}
  3538. tprocdef(result).exp_funcretloc:=exp_funcretloc;
  3539. {$endif}
  3540. { don't copy mangled name, can be different }
  3541. tprocdef(result).messageinf:=messageinf;
  3542. if po_msgstr in procoptions then
  3543. tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
  3544. tprocdef(result).symoptions:=symoptions;
  3545. if assigned(deprecatedmsg) then
  3546. tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
  3547. { will have to be associated with appropriate procsym }
  3548. tprocdef(result).procsym:=nil;
  3549. tprocdef(result).aliasnames.concatListcopy(aliasnames);
  3550. if assigned(funcretsym) then
  3551. begin
  3552. if (funcretsym.owner=parast) then
  3553. begin
  3554. j:=parast.symlist.indexof(funcretsym);
  3555. if j<0 then
  3556. internalerror(2011040606);
  3557. tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
  3558. end
  3559. else
  3560. internalerror(2011040605);
  3561. end;
  3562. { will have to be associated with a new struct }
  3563. tprocdef(result).struct:=nil;
  3564. {$if defined(powerpc) or defined(m68k)}
  3565. tprocdef(result).libsym:=libsym;
  3566. {$endif powerpc or m68k}
  3567. if assigned(resultname) then
  3568. tprocdef(result).resultname:=stringdup(resultname^);
  3569. if assigned(import_dll) then
  3570. tprocdef(result).import_dll:=stringdup(import_dll^);
  3571. if assigned(import_name) then
  3572. tprocdef(result).import_name:=stringdup(import_name^);
  3573. tprocdef(result).import_nr:=import_nr;
  3574. tprocdef(result).extnumber:=$ffff;
  3575. {$ifdef i386}
  3576. tprocdef(result).fpu_used:=fpu_used;
  3577. {$endif i386}
  3578. tprocdef(result).visibility:=visibility;
  3579. tprocdef(result).synthetickind:=synthetickind;
  3580. { we need a separate implementation for the copied def }
  3581. tprocdef(result).forwarddef:=true;
  3582. tprocdef(result).interfacedef:=true;
  3583. { create new paralist }
  3584. tprocdef(result).calcparas;
  3585. end;
  3586. procedure tprocdef.buildderef;
  3587. begin
  3588. inherited buildderef;
  3589. structderef.build(struct);
  3590. { procsym that originaly defined this definition, should be in the
  3591. same symtable }
  3592. procsymderef.build(procsym);
  3593. {$ifdef powerpc}
  3594. { library symbol for AmigaOS/MorphOS }
  3595. libsymderef.build(libsym);
  3596. {$endif powerpc}
  3597. end;
  3598. procedure tprocdef.buildderefimpl;
  3599. begin
  3600. inherited buildderefimpl;
  3601. { Localst is not available for main/unit init }
  3602. if assigned(localst) then
  3603. begin
  3604. tlocalsymtable(localst).buildderef;
  3605. tlocalsymtable(localst).buildderefimpl;
  3606. end;
  3607. { inline tree }
  3608. if (po_has_inlininginfo in procoptions) then
  3609. begin
  3610. funcretsymderef.build(funcretsym);
  3611. inlininginfo^.code.buildderefimpl;
  3612. end;
  3613. end;
  3614. procedure tprocdef.deref;
  3615. begin
  3616. inherited deref;
  3617. struct:=tabstractrecorddef(structderef.resolve);
  3618. { procsym that originaly defined this definition, should be in the
  3619. same symtable }
  3620. procsym:=tprocsym(procsymderef.resolve);
  3621. {$ifdef powerpc}
  3622. { library symbol for AmigaOS/MorphOS }
  3623. libsym:=tsym(libsymderef.resolve);
  3624. {$endif powerpc}
  3625. end;
  3626. procedure tprocdef.derefimpl;
  3627. begin
  3628. { Enable has_inlininginfo when the inlininginfo
  3629. structure is available. The has_inlininginfo was disabled
  3630. after the load, since the data was invalid }
  3631. if assigned(inlininginfo) then
  3632. include(procoptions,po_has_inlininginfo);
  3633. { Locals }
  3634. if assigned(localst) then
  3635. begin
  3636. tlocalsymtable(localst).deref;
  3637. tlocalsymtable(localst).derefimpl;
  3638. end;
  3639. { Inline }
  3640. if (po_has_inlininginfo in procoptions) then
  3641. begin
  3642. inlininginfo^.code.derefimpl;
  3643. { funcretsym, this is always located in the localst }
  3644. funcretsym:=tsym(funcretsymderef.resolve);
  3645. end
  3646. else
  3647. begin
  3648. { safety }
  3649. { Not safe! A unit may be reresolved after its interface has been
  3650. parsed but before its implementation has been parsed, and in that
  3651. case the funcretsym is still required!
  3652. funcretsym:=nil; }
  3653. end;
  3654. end;
  3655. function tprocdef.GetTypeName : string;
  3656. begin
  3657. GetTypeName := FullProcName(false);
  3658. end;
  3659. function tprocdef.mangledname : string;
  3660. begin
  3661. if assigned(_mangledname) then
  3662. begin
  3663. {$ifdef compress}
  3664. mangledname:=minilzw_decode(_mangledname^);
  3665. {$else}
  3666. mangledname:=_mangledname^;
  3667. {$endif}
  3668. exit;
  3669. end;
  3670. {$ifndef jvm}
  3671. mangledname:=defaultmangledname;
  3672. {$else not jvm}
  3673. mangledname:=jvmmangledbasename;
  3674. if (po_has_importdll in procoptions) then
  3675. begin
  3676. { import_dll comes from "external 'import_dll_name' name 'external_name'" }
  3677. if assigned(import_dll) then
  3678. mangledname:=import_dll^+'/'+mangledname
  3679. else
  3680. internalerror(2010122607);
  3681. end
  3682. else
  3683. jvmaddtypeownerprefix(owner,mangledname);
  3684. {$endif not jvm}
  3685. {$ifdef compress}
  3686. _mangledname:=stringdup(minilzw_encode(mangledname));
  3687. {$else}
  3688. _mangledname:=stringdup(mangledname);
  3689. {$endif}
  3690. end;
  3691. function tprocdef.defaultmangledname: string;
  3692. var
  3693. hp : TParavarsym;
  3694. hs : string;
  3695. crc : dword;
  3696. newlen,
  3697. oldlen,
  3698. i : integer;
  3699. begin
  3700. { we need to use the symtable where the procsym is inserted,
  3701. because that is visible to the world }
  3702. defaultmangledname:=make_mangledname('',procsym.owner,procsym.name);
  3703. oldlen:=length(defaultmangledname);
  3704. { add parameter types }
  3705. for i:=0 to paras.count-1 do
  3706. begin
  3707. hp:=tparavarsym(paras[i]);
  3708. if not(vo_is_hidden_para in hp.varoptions) then
  3709. defaultmangledname:=defaultmangledname+'$'+hp.vardef.mangledparaname;
  3710. end;
  3711. { add resultdef, add $$ as separator to make it unique from a
  3712. parameter separator }
  3713. if not is_void(returndef) then
  3714. defaultmangledname:=defaultmangledname+'$$'+returndef.mangledparaname;
  3715. newlen:=length(defaultmangledname);
  3716. { Replace with CRC if the parameter line is very long }
  3717. if (newlen-oldlen>12) and
  3718. ((newlen>100) or (newlen-oldlen>64)) then
  3719. begin
  3720. crc:=0;
  3721. for i:=0 to paras.count-1 do
  3722. begin
  3723. hp:=tparavarsym(paras[i]);
  3724. if not(vo_is_hidden_para in hp.varoptions) then
  3725. begin
  3726. hs:=hp.vardef.mangledparaname;
  3727. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3728. end;
  3729. end;
  3730. hs:=hp.vardef.mangledparaname;
  3731. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3732. defaultmangledname:=Copy(defaultmangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  3733. end;
  3734. end;
  3735. function tprocdef.cplusplusmangledname : string;
  3736. function getcppparaname(p : tdef) : string;
  3737. const
  3738. {$ifdef NAMEMANGLING_GCC2}
  3739. ordtype2str : array[tordtype] of string[2] = (
  3740. '',
  3741. 'Uc','Us','Ui','Us',
  3742. 'Sc','s','i','x',
  3743. 'b','b','b','b','b',
  3744. 'c','w','x');
  3745. {$else NAMEMANGLING_GCC2}
  3746. ordtype2str : array[tordtype] of string[1] = (
  3747. 'v',
  3748. 'h','t','j','y',
  3749. 'a','s','i','x',
  3750. 'b','b','b','b',
  3751. 'b','b','b','b',
  3752. 'c','w','x');
  3753. floattype2str : array[tfloattype] of string[1] = (
  3754. 'f','d','e','e',
  3755. 'd','d','g');
  3756. {$endif NAMEMANGLING_GCC2}
  3757. var
  3758. s : string;
  3759. begin
  3760. case p.typ of
  3761. orddef:
  3762. s:=ordtype2str[torddef(p).ordtype];
  3763. pointerdef:
  3764. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  3765. {$ifndef NAMEMANGLING_GCC2}
  3766. floatdef:
  3767. s:=floattype2str[tfloatdef(p).floattype];
  3768. {$endif NAMEMANGLING_GCC2}
  3769. else
  3770. internalerror(2103001);
  3771. end;
  3772. getcppparaname:=s;
  3773. end;
  3774. var
  3775. s,s2 : string;
  3776. hp : TParavarsym;
  3777. i : integer;
  3778. begin
  3779. {$ifdef NAMEMANGLING_GCC2}
  3780. { outdated gcc 2.x name mangling scheme }
  3781. s := procsym.realname;
  3782. if procsym.owner.symtabletype=ObjectSymtable then
  3783. begin
  3784. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  3785. case proctypeoption of
  3786. potype_destructor:
  3787. s:='_$_'+tostr(length(s2))+s2;
  3788. potype_constructor:
  3789. s:='___'+tostr(length(s2))+s2;
  3790. else
  3791. s:='_'+s+'__'+tostr(length(s2))+s2;
  3792. end;
  3793. end
  3794. else s:=s+'__';
  3795. s:=s+'F';
  3796. { concat modifiers }
  3797. { !!!!! }
  3798. { now we handle the parameters }
  3799. if maxparacount>0 then
  3800. begin
  3801. for i:=0 to paras.count-1 do
  3802. begin
  3803. hp:=tparavarsym(paras[i]);
  3804. { no hidden parameters form part of a C++ mangled name:
  3805. a) self is not included
  3806. b) there are no "high" or other hidden parameters
  3807. }
  3808. if vo_is_hidden_para in hp.varoptions then
  3809. continue;
  3810. s2:=getcppparaname(hp.vardef);
  3811. if hp.varspez in [vs_var,vs_out] then
  3812. s2:='R'+s2;
  3813. s:=s+s2;
  3814. end;
  3815. end
  3816. else
  3817. s:=s+'v';
  3818. cplusplusmangledname:=s;
  3819. {$else NAMEMANGLING_GCC2}
  3820. { gcc 3.x and 4.x name mangling scheme }
  3821. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  3822. if procsym.owner.symtabletype=ObjectSymtable then
  3823. begin
  3824. s:='_ZN';
  3825. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  3826. s:=s+tostr(length(s2))+s2;
  3827. case proctypeoption of
  3828. potype_constructor:
  3829. s:=s+'C1';
  3830. potype_destructor:
  3831. s:=s+'D1';
  3832. else
  3833. s:=s+tostr(length(procsym.realname))+procsym.realname;
  3834. end;
  3835. s:=s+'E';
  3836. end
  3837. else
  3838. s:=procsym.realname;
  3839. { now we handle the parameters }
  3840. if maxparacount>0 then
  3841. begin
  3842. for i:=0 to paras.count-1 do
  3843. begin
  3844. hp:=tparavarsym(paras[i]);
  3845. { no hidden parameters form part of a C++ mangled name:
  3846. a) self is not included
  3847. b) there are no "high" or other hidden parameters
  3848. }
  3849. if vo_is_hidden_para in hp.varoptions then
  3850. continue;
  3851. s2:=getcppparaname(hp.vardef);
  3852. if hp.varspez in [vs_var,vs_out] then
  3853. s2:='R'+s2;
  3854. s:=s+s2;
  3855. end;
  3856. end
  3857. else
  3858. s:=s+'v';
  3859. cplusplusmangledname:=s;
  3860. {$endif NAMEMANGLING_GCC2}
  3861. end;
  3862. function tprocdef.objcmangledname : string;
  3863. var
  3864. manglednamelen: longint;
  3865. iscatmethod : boolean;
  3866. begin
  3867. if not (po_msgstr in procoptions) then
  3868. internalerror(2009030901);
  3869. { we may very well need longer strings to handle these... }
  3870. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  3871. length('+"[ ]"')+length(messageinf.str^);
  3872. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  3873. if (iscatmethod) then
  3874. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  3875. if manglednamelen>255 then
  3876. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  3877. if not(po_classmethod in procoptions) then
  3878. result:='"-['
  3879. else
  3880. result:='"+[';
  3881. { quotes are necessary because the +/- otherwise confuse the assembler
  3882. into expecting a number
  3883. }
  3884. if iscatmethod then
  3885. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  3886. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  3887. if iscatmethod then
  3888. result:=result+')';
  3889. result:=result+' '+messageinf.str^+']"';
  3890. end;
  3891. function tprocdef.jvmmangledbasename: string;
  3892. var
  3893. vs: tparavarsym;
  3894. i: longint;
  3895. founderror: tdef;
  3896. tmpresult: string;
  3897. begin
  3898. { format:
  3899. * method definition (in Jasmin):
  3900. (private|protected|public) [static] method(parametertypes)returntype
  3901. * method invocation
  3902. package/class/method(parametertypes)returntype
  3903. -> store common part: method(parametertypes)returntype and
  3904. adorn as required when using it.
  3905. }
  3906. { method name }
  3907. { special names for constructors and class constructors }
  3908. if proctypeoption=potype_constructor then
  3909. tmpresult:='<init>'
  3910. else if proctypeoption in [potype_class_constructor,potype_unitinit] then
  3911. tmpresult:='<clinit>'
  3912. else if po_has_importname in procoptions then
  3913. begin
  3914. if assigned(import_name) then
  3915. tmpresult:=import_name^
  3916. else
  3917. internalerror(2010122608);
  3918. end
  3919. else
  3920. begin
  3921. tmpresult:=procsym.realname;
  3922. if tmpresult[1]='$' then
  3923. tmpresult:=copy(tmpresult,2,length(tmpresult)-1);
  3924. end;
  3925. { parameter types }
  3926. tmpresult:=tmpresult+'(';
  3927. { not the case for the main program (not required for defaultmangledname
  3928. because setmangledname() is called for the main program; in case of
  3929. the JVM, this only sets the importname, however) }
  3930. if assigned(paras) then
  3931. begin
  3932. init_paraloc_info(callerside);
  3933. for i:=0 to paras.count-1 do
  3934. begin
  3935. vs:=tparavarsym(paras[i]);
  3936. { function result and self pointer are not part of the mangled
  3937. name }
  3938. if ([vo_is_funcret,vo_is_self] * vs.varoptions <> []) then
  3939. continue;
  3940. { reference parameters are not yet supported }
  3941. if (vs.varspez in [vs_var,vs_out,vs_constref]) then
  3942. begin
  3943. { passing by reference is emulated by passing an array of one
  3944. element containing the value; for types that aren't pointers
  3945. in regular Pascal, simply passing the underlying pointer type
  3946. does achieve regular call-by-reference semantics though }
  3947. if not jvmimplicitpointertype(vs.vardef) then
  3948. tmpresult:=tmpresult+'[';
  3949. end;
  3950. { Add the parameter type. }
  3951. if not jvmaddencodedtype(vs.vardef,false,tmpresult,founderror) then
  3952. { should be checked earlier on }
  3953. internalerror(2010122604);
  3954. end;
  3955. end;
  3956. tmpresult:=tmpresult+')';
  3957. { And the type of the function result (void in case of a procedure and
  3958. constructor). }
  3959. if (proctypeoption in [potype_constructor,potype_class_constructor]) then
  3960. jvmaddencodedtype(voidtype,false,tmpresult,founderror)
  3961. else if not jvmaddencodedtype(returndef,false,tmpresult,founderror) then
  3962. internalerror(2010122610);
  3963. result:=tmpresult;
  3964. end;
  3965. procedure tprocdef.setmangledname(const s : string);
  3966. begin
  3967. { This is not allowed anymore, the forward declaration
  3968. already needs to create the correct mangledname, no changes
  3969. afterwards are allowed (PFV) }
  3970. { Exception: interface definitions in mode macpas, since in that }
  3971. { case no reference to the old name can exist yet (JM) }
  3972. if assigned(_mangledname) then
  3973. if ((m_mac in current_settings.modeswitches) and
  3974. (interfacedef)) then
  3975. stringdispose(_mangledname)
  3976. else
  3977. internalerror(200411171);
  3978. {$ifdef jvm}
  3979. { this routine can be called for compilerproces. can't set mangled
  3980. name since it must be calculated, but it uses import_name when set
  3981. -> set that one }
  3982. import_name:=stringdup(s);
  3983. include(procoptions,po_has_importname);
  3984. include(procoptions,po_has_mangledname);
  3985. {$else}
  3986. {$ifdef compress}
  3987. _mangledname:=stringdup(minilzw_encode(s));
  3988. {$else}
  3989. _mangledname:=stringdup(s);
  3990. {$endif}
  3991. {$endif jvm}
  3992. include(procoptions,po_has_mangledname);
  3993. end;
  3994. {***************************************************************************
  3995. TPROCVARDEF
  3996. ***************************************************************************}
  3997. constructor tprocvardef.create(level:byte);
  3998. begin
  3999. inherited create(procvardef,level);
  4000. end;
  4001. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  4002. begin
  4003. inherited ppuload(procvardef,ppufile);
  4004. { load para symtable }
  4005. parast:=tparasymtable.create(self,ppufile.getbyte);
  4006. tparasymtable(parast).ppuload(ppufile);
  4007. end;
  4008. function tprocvardef.getcopy : tstoreddef;
  4009. var
  4010. i : tcallercallee;
  4011. j : longint;
  4012. begin
  4013. result:=tprocvardef.create(parast.symtablelevel);
  4014. tprocvardef(result).returndef:=returndef;
  4015. tprocvardef(result).returndefderef:=returndefderef;
  4016. tprocvardef(result).parast:=parast.getcopy;
  4017. tprocvardef(result).savesize:=savesize;
  4018. { create paralist copy }
  4019. tprocvardef(result).paras:=tparalist.create(false);
  4020. tprocvardef(result).paras.count:=paras.count;
  4021. for j:=0 to paras.count-1 do
  4022. tprocvardef(result).paras[j]:=paras[j];
  4023. tprocvardef(result).proctypeoption:=proctypeoption;
  4024. tprocvardef(result).proccalloption:=proccalloption;
  4025. tprocvardef(result).procoptions:=procoptions;
  4026. tprocvardef(result).callerargareasize:=callerargareasize;
  4027. tprocvardef(result).calleeargareasize:=calleeargareasize;
  4028. tprocvardef(result).maxparacount:=maxparacount;
  4029. tprocvardef(result).minparacount:=minparacount;
  4030. for i:=low(tcallercallee) to high(tcallercallee) do
  4031. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  4032. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  4033. {$ifdef m68k}
  4034. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  4035. {$endif}
  4036. end;
  4037. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  4038. begin
  4039. inherited ppuwrite(ppufile);
  4040. { Save the para symtable level (necessary to distinguish nested
  4041. procvars) }
  4042. ppufile.putbyte(parast.symtablelevel);
  4043. { Write this entry }
  4044. ppufile.writeentry(ibprocvardef);
  4045. { Save the para symtable, this is taken from the interface }
  4046. tparasymtable(parast).ppuwrite(ppufile);
  4047. end;
  4048. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  4049. begin
  4050. case t of
  4051. gs_para :
  4052. GetSymtable:=parast;
  4053. else
  4054. GetSymtable:=nil;
  4055. end;
  4056. end;
  4057. function tprocvardef.size : asizeint;
  4058. begin
  4059. if ((po_methodpointer in procoptions) or
  4060. is_nested_pd(self)) and
  4061. not(po_addressonly in procoptions) then
  4062. size:=2*sizeof(pint)
  4063. else
  4064. size:=sizeof(pint);
  4065. end;
  4066. function tprocvardef.is_methodpointer:boolean;
  4067. begin
  4068. result:=(po_methodpointer in procoptions);
  4069. end;
  4070. function tprocvardef.is_addressonly:boolean;
  4071. begin
  4072. result:=(not(po_methodpointer in procoptions) and
  4073. not is_nested_pd(self)) or
  4074. (po_addressonly in procoptions);
  4075. end;
  4076. function tprocvardef.getmangledparaname:string;
  4077. begin
  4078. if not(po_methodpointer in procoptions) then
  4079. if not is_nested_pd(self) then
  4080. result:='procvar'
  4081. else
  4082. result:='nestedprovar'
  4083. else
  4084. result:='procvarofobj'
  4085. end;
  4086. function tprocvardef.is_publishable : boolean;
  4087. begin
  4088. is_publishable:=(po_methodpointer in procoptions);
  4089. end;
  4090. function tprocvardef.GetTypeName : string;
  4091. var
  4092. s: string;
  4093. pno : tprocnameoptions;
  4094. begin
  4095. {$ifdef EXTDEBUG}
  4096. pno:=[pno_showhidden];
  4097. {$else EXTDEBUG}
  4098. pno:=[];
  4099. {$endif EXTDEBUG}
  4100. s:='<';
  4101. if po_classmethod in procoptions then
  4102. s := s+'class method type of'
  4103. else
  4104. if po_addressonly in procoptions then
  4105. s := s+'address of'
  4106. else
  4107. s := s+'procedure variable type of';
  4108. if assigned(returndef) and
  4109. (returndef<>voidtype) then
  4110. s:=s+' function'+typename_paras(pno)+':'+returndef.GetTypeName
  4111. else
  4112. s:=s+' procedure'+typename_paras(pno);
  4113. if po_methodpointer in procoptions then
  4114. s := s+' of object';
  4115. if is_nested_pd(self) then
  4116. s := s+' is nested';
  4117. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  4118. end;
  4119. {***************************************************************************
  4120. TOBJECTDEF
  4121. ***************************************************************************}
  4122. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef);
  4123. begin
  4124. inherited create(n,objectdef);
  4125. fcurrent_dispid:=0;
  4126. objecttype:=ot;
  4127. childof:=nil;
  4128. if objecttype=odt_helper then
  4129. owner.includeoption(sto_has_helper);
  4130. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
  4131. { create space for vmt !! }
  4132. vmtentries:=TFPList.Create;
  4133. vmt_offset:=0;
  4134. set_parent(c);
  4135. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  4136. prepareguid;
  4137. { setup implemented interfaces }
  4138. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4139. ImplementedInterfaces:=TFPObjectList.Create(true)
  4140. else
  4141. ImplementedInterfaces:=nil;
  4142. writing_class_record_dbginfo:=false;
  4143. end;
  4144. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  4145. var
  4146. i,
  4147. implintfcount : longint;
  4148. d : tderef;
  4149. ImplIntf : TImplementedInterface;
  4150. vmtentry : pvmtentry;
  4151. begin
  4152. inherited ppuload(objectdef,ppufile);
  4153. objecttype:=tobjecttyp(ppufile.getbyte);
  4154. objextname:=stringdup(ppufile.getstring);
  4155. { only used for external Objective-C classes/protocols }
  4156. if (objextname^='') then
  4157. stringdispose(objextname);
  4158. symtable:=tObjectSymtable.create(self,objrealname^,0);
  4159. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  4160. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  4161. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  4162. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  4163. vmt_offset:=ppufile.getlongint;
  4164. ppufile.getderef(childofderef);
  4165. { load guid }
  4166. iidstr:=nil;
  4167. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4168. begin
  4169. new(iidguid);
  4170. ppufile.getguid(iidguid^);
  4171. iidstr:=stringdup(ppufile.getstring);
  4172. end;
  4173. if objecttype=odt_helper then
  4174. ppufile.getderef(extendeddefderef);
  4175. vmtentries:=TFPList.Create;
  4176. vmtentries.count:=ppufile.getlongint;
  4177. for i:=0 to vmtentries.count-1 do
  4178. begin
  4179. ppufile.getderef(d);
  4180. new(vmtentry);
  4181. vmtentry^.procdef:=nil;
  4182. vmtentry^.procdefderef:=d;
  4183. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  4184. vmtentries[i]:=vmtentry;
  4185. end;
  4186. { load implemented interfaces }
  4187. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_interfacejava] then
  4188. begin
  4189. ImplementedInterfaces:=TFPObjectList.Create(true);
  4190. implintfcount:=ppufile.getlongint;
  4191. for i:=0 to implintfcount-1 do
  4192. begin
  4193. ppufile.getderef(d);
  4194. ImplIntf:=TImplementedInterface.Create_deref(d);
  4195. ImplIntf.IOffset:=ppufile.getlongint;
  4196. ImplementedInterfaces.Add(ImplIntf);
  4197. end;
  4198. end
  4199. else
  4200. ImplementedInterfaces:=nil;
  4201. if df_copied_def in defoptions then
  4202. ppufile.getderef(cloneddefderef)
  4203. else
  4204. tObjectSymtable(symtable).ppuload(ppufile);
  4205. { handles the predefined class tobject }
  4206. { the last TOBJECT which is loaded gets }
  4207. { it ! }
  4208. if (childof=nil) and
  4209. (objecttype in [odt_class,odt_javaclass]) and
  4210. (objname^='TOBJECT') then
  4211. class_tobject:=self;
  4212. if (childof=nil) and
  4213. (objecttype=odt_interfacecom) then
  4214. if (objname^='IUNKNOWN') then
  4215. interface_iunknown:=self
  4216. else
  4217. if (objname^='IDISPATCH') then
  4218. interface_idispatch:=self;
  4219. if (childof=nil) and
  4220. (objecttype=odt_objcclass) and
  4221. (objname^='PROTOCOL') then
  4222. objc_protocoltype:=self;
  4223. if (objecttype=odt_javaclass) and
  4224. not(oo_is_formal in objectoptions) then
  4225. begin
  4226. if (objname^='JLOBJECT') then
  4227. java_jlobject:=self;
  4228. if (objname^='JLTHROWABLE') then
  4229. java_jlthrowable:=self;
  4230. if (objname^='FPCBASERECORDTYPE') then
  4231. java_fpcbaserecordtype:=self;
  4232. if (objname^='JLSTRING') then
  4233. java_jlstring:=self;
  4234. end;
  4235. writing_class_record_dbginfo:=false;
  4236. end;
  4237. destructor tobjectdef.destroy;
  4238. begin
  4239. if assigned(symtable) then
  4240. begin
  4241. symtable.free;
  4242. symtable:=nil;
  4243. end;
  4244. stringdispose(objextname);
  4245. stringdispose(iidstr);
  4246. if assigned(ImplementedInterfaces) then
  4247. begin
  4248. ImplementedInterfaces.free;
  4249. ImplementedInterfaces:=nil;
  4250. end;
  4251. if assigned(iidguid) then
  4252. begin
  4253. dispose(iidguid);
  4254. iidguid:=nil;
  4255. end;
  4256. if assigned(vmtentries) then
  4257. begin
  4258. resetvmtentries;
  4259. vmtentries.free;
  4260. vmtentries:=nil;
  4261. end;
  4262. if assigned(vmcallstaticinfo) then
  4263. begin
  4264. freemem(vmcallstaticinfo);
  4265. vmcallstaticinfo:=nil;
  4266. end;
  4267. inherited destroy;
  4268. end;
  4269. function tobjectdef.getcopy : tstoreddef;
  4270. var
  4271. i : longint;
  4272. begin
  4273. result:=tobjectdef.create(objecttype,objrealname^,childof);
  4274. { the constructor allocates a symtable which we release to avoid memory leaks }
  4275. tobjectdef(result).symtable.free;
  4276. tobjectdef(result).symtable:=symtable.getcopy;
  4277. if assigned(objextname) then
  4278. tobjectdef(result).objextname:=stringdup(objextname^);
  4279. if assigned(import_lib) then
  4280. tobjectdef(result).import_lib:=stringdup(import_lib^);
  4281. tobjectdef(result).objectoptions:=objectoptions;
  4282. include(tobjectdef(result).defoptions,df_copied_def);
  4283. tobjectdef(result).extendeddef:=extendeddef;
  4284. if assigned(tcinitcode) then
  4285. tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
  4286. tobjectdef(result).vmt_offset:=vmt_offset;
  4287. if assigned(iidguid) then
  4288. begin
  4289. new(tobjectdef(result).iidguid);
  4290. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  4291. end;
  4292. if assigned(iidstr) then
  4293. tobjectdef(result).iidstr:=stringdup(iidstr^);
  4294. if assigned(ImplementedInterfaces) then
  4295. begin
  4296. for i:=0 to ImplementedInterfaces.count-1 do
  4297. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  4298. end;
  4299. if assigned(vmtentries) then
  4300. begin
  4301. tobjectdef(result).vmtentries:=TFPList.Create;
  4302. tobjectdef(result).copyvmtentries(self);
  4303. end;
  4304. end;
  4305. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  4306. var
  4307. i : longint;
  4308. vmtentry : pvmtentry;
  4309. ImplIntf : TImplementedInterface;
  4310. old_do_indirect_crc: boolean;
  4311. begin
  4312. { if class1 in unit A changes, and class2 in unit B inherits from it
  4313. (so unit B uses unit A), then unit B with class2 will be recompiled.
  4314. However, if there is also a class3 in unit C that only depends on
  4315. unit B, then unit C will not be recompiled because nothing changed
  4316. to the interface of unit B. Nevertheless, unit C can indirectly
  4317. depend on unit A via derefs, and these must be updated -> the
  4318. indirect crc keeps track of such changes. }
  4319. old_do_indirect_crc:=ppufile.do_indirect_crc;
  4320. ppufile.do_indirect_crc:=true;
  4321. inherited ppuwrite(ppufile);
  4322. ppufile.putbyte(byte(objecttype));
  4323. if assigned(objextname) then
  4324. ppufile.putstring(objextname^)
  4325. else
  4326. ppufile.putstring('');
  4327. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  4328. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  4329. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  4330. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  4331. ppufile.putlongint(vmt_offset);
  4332. ppufile.putderef(childofderef);
  4333. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4334. begin
  4335. ppufile.putguid(iidguid^);
  4336. ppufile.putstring(iidstr^);
  4337. end;
  4338. if objecttype=odt_helper then
  4339. ppufile.putderef(extendeddefderef);
  4340. ppufile.putlongint(vmtentries.count);
  4341. for i:=0 to vmtentries.count-1 do
  4342. begin
  4343. vmtentry:=pvmtentry(vmtentries[i]);
  4344. ppufile.putderef(vmtentry^.procdefderef);
  4345. ppufile.putbyte(byte(vmtentry^.visibility));
  4346. end;
  4347. if assigned(ImplementedInterfaces) then
  4348. begin
  4349. ppufile.putlongint(ImplementedInterfaces.Count);
  4350. for i:=0 to ImplementedInterfaces.Count-1 do
  4351. begin
  4352. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4353. ppufile.putderef(ImplIntf.intfdefderef);
  4354. ppufile.putlongint(ImplIntf.Ioffset);
  4355. end;
  4356. end;
  4357. if df_copied_def in defoptions then
  4358. ppufile.putderef(cloneddefderef);
  4359. ppufile.writeentry(ibobjectdef);
  4360. if not(df_copied_def in defoptions) then
  4361. tObjectSymtable(symtable).ppuwrite(ppufile);
  4362. ppufile.do_indirect_crc:=old_do_indirect_crc;
  4363. end;
  4364. function tobjectdef.GetTypeName:string;
  4365. begin
  4366. { in this case we will go in endless recursion, because then }
  4367. { there is no tsym associated yet with the def. It can occur }
  4368. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  4369. { instead of the actual type name }
  4370. if not assigned(typesym) then
  4371. result:='<Currently Parsed Class>'
  4372. else
  4373. result:=typesymbolprettyname;
  4374. end;
  4375. procedure tobjectdef.buildderef;
  4376. var
  4377. i : longint;
  4378. vmtentry : pvmtentry;
  4379. begin
  4380. inherited buildderef;
  4381. childofderef.build(childof);
  4382. if df_copied_def in defoptions then
  4383. cloneddefderef.build(symtable.defowner)
  4384. else
  4385. tstoredsymtable(symtable).buildderef;
  4386. if objecttype=odt_helper then
  4387. extendeddefderef.build(extendeddef);
  4388. for i:=0 to vmtentries.count-1 do
  4389. begin
  4390. vmtentry:=pvmtentry(vmtentries[i]);
  4391. vmtentry^.procdefderef.build(vmtentry^.procdef);
  4392. end;
  4393. if assigned(ImplementedInterfaces) then
  4394. begin
  4395. for i:=0 to ImplementedInterfaces.count-1 do
  4396. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  4397. end;
  4398. end;
  4399. procedure tobjectdef.deref;
  4400. var
  4401. i : longint;
  4402. vmtentry : pvmtentry;
  4403. begin
  4404. inherited deref;
  4405. childof:=tobjectdef(childofderef.resolve);
  4406. if df_copied_def in defoptions then
  4407. begin
  4408. cloneddef:=tobjectdef(cloneddefderef.resolve);
  4409. symtable:=cloneddef.symtable.getcopy;
  4410. end
  4411. else
  4412. tstoredsymtable(symtable).deref;
  4413. if objecttype=odt_helper then
  4414. extendeddef:=tobjectdef(extendeddefderef.resolve);
  4415. for i:=0 to vmtentries.count-1 do
  4416. begin
  4417. vmtentry:=pvmtentry(vmtentries[i]);
  4418. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  4419. end;
  4420. if assigned(ImplementedInterfaces) then
  4421. begin
  4422. for i:=0 to ImplementedInterfaces.count-1 do
  4423. TImplementedInterface(ImplementedInterfaces[i]).deref;
  4424. end;
  4425. end;
  4426. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  4427. var
  4428. pd: tprocdef absolute def;
  4429. st: tsymtable;
  4430. psym: tsym;
  4431. nname: TIDString;
  4432. begin
  4433. if (tdef(def).typ<>procdef) then
  4434. exit;
  4435. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  4436. owner = symtable in which objcclassdef is defined
  4437. }
  4438. st:=pd.owner.defowner.owner;
  4439. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  4440. { check for an existing procsym with our special name }
  4441. psym:=tsym(st.find(nname));
  4442. if not assigned(psym) then
  4443. begin
  4444. psym:=tprocsym.create(nname);
  4445. { avoid warning about this symbol being unused }
  4446. psym.IncRefCount;
  4447. { don't check for duplicates:
  4448. a) we checked above
  4449. b) in case we are in the implementation section of a unit, this
  4450. will also check for this symbol in the interface section
  4451. (since you normally cannot have symbols with the same name
  4452. both interface and implementation), and it's possible to
  4453. have class helpers for the same class in the interface and
  4454. in the implementation, and they cannot be merged since only
  4455. the once in the interface must be saved to the ppu/visible
  4456. from other units }
  4457. st.insert(psym,false);
  4458. end
  4459. else if (psym.typ<>procsym) then
  4460. internalerror(2009111501);
  4461. { add ourselves to this special procsym }
  4462. tprocsym(psym).procdeflist.add(def);
  4463. end;
  4464. procedure tobjectdef.buildderefimpl;
  4465. begin
  4466. inherited buildderefimpl;
  4467. if not (df_copied_def in defoptions) then
  4468. tstoredsymtable(symtable).buildderefimpl;
  4469. end;
  4470. procedure tobjectdef.derefimpl;
  4471. begin
  4472. inherited derefimpl;
  4473. if not (df_copied_def in defoptions) then
  4474. tstoredsymtable(symtable).derefimpl;
  4475. { the procdefs are not owned by the class helper procsyms, so they
  4476. are not stored/restored either -> re-add them here }
  4477. if (objecttype=odt_objcclass) or
  4478. (oo_is_classhelper in objectoptions) then
  4479. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  4480. end;
  4481. procedure tobjectdef.resetvmtentries;
  4482. var
  4483. i : longint;
  4484. begin
  4485. for i:=0 to vmtentries.Count-1 do
  4486. Dispose(pvmtentry(vmtentries[i]));
  4487. vmtentries.clear;
  4488. end;
  4489. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  4490. var
  4491. i : longint;
  4492. vmtentry : pvmtentry;
  4493. begin
  4494. resetvmtentries;
  4495. vmtentries.count:=objdef.vmtentries.count;
  4496. for i:=0 to objdef.vmtentries.count-1 do
  4497. begin
  4498. new(vmtentry);
  4499. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  4500. vmtentries[i]:=vmtentry;
  4501. end;
  4502. end;
  4503. function tobjectdef.getparentdef:tdef;
  4504. begin
  4505. { TODO: Remove getparentdef hack}
  4506. { With 2 forward declared classes with the child class before the
  4507. parent class the child class is written earlier to the ppu. Leaving it
  4508. possible to have a reference to the parent class for property overriding,
  4509. but the parent class still has the childof not resolved yet (PFV) }
  4510. if childof=nil then
  4511. childof:=tobjectdef(childofderef.resolve);
  4512. result:=childof;
  4513. end;
  4514. procedure tobjectdef.prepareguid;
  4515. begin
  4516. { set up guid }
  4517. if not assigned(iidguid) then
  4518. begin
  4519. new(iidguid);
  4520. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  4521. end;
  4522. { setup iidstring }
  4523. if not assigned(iidstr) then
  4524. iidstr:=stringdup(''); { default is empty string }
  4525. end;
  4526. procedure tobjectdef.set_parent( c : tobjectdef);
  4527. begin
  4528. if assigned(childof) then
  4529. exit;
  4530. childof:=c;
  4531. if not assigned(c) then
  4532. exit;
  4533. { inherit options and status }
  4534. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  4535. { add the data of the anchestor class/object }
  4536. if (objecttype in [odt_class,odt_object,odt_objcclass,odt_javaclass]) then
  4537. begin
  4538. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  4539. { inherit recordalignment }
  4540. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  4541. { if both the parent and this record use C-alignment, also inherit
  4542. the current field alignment }
  4543. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  4544. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  4545. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  4546. { the padding is not inherited for Objective-C classes (maybe not
  4547. for cppclass either?) }
  4548. if objecttype=odt_objcclass then
  4549. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  4550. if (oo_has_vmt in objectoptions) and
  4551. (oo_has_vmt in c.objectoptions) then
  4552. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  4553. { if parent has a vmt field then the offset is the same for the child PM }
  4554. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  4555. begin
  4556. vmt_offset:=c.vmt_offset;
  4557. include(objectoptions,oo_has_vmt);
  4558. end;
  4559. end;
  4560. end;
  4561. procedure tobjectdef.insertvmt;
  4562. var
  4563. vs: tfieldvarsym;
  4564. begin
  4565. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4566. exit;
  4567. if (oo_has_vmt in objectoptions) then
  4568. internalerror(12345)
  4569. else
  4570. begin
  4571. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  4572. tObjectSymtable(symtable).fieldalignment);
  4573. if (tf_requires_proper_alignment in target_info.flags) then
  4574. begin
  4575. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  4576. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  4577. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  4578. end;
  4579. vs:=tfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  4580. hidesym(vs);
  4581. tObjectSymtable(symtable).insert(vs);
  4582. tObjectSymtable(symtable).addfield(vs,vis_hidden);
  4583. if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  4584. vmt_offset:=vs.fieldoffset
  4585. else
  4586. vmt_offset:=vs.fieldoffset div 8;
  4587. include(objectoptions,oo_has_vmt);
  4588. end;
  4589. end;
  4590. procedure tobjectdef.check_forwards;
  4591. begin
  4592. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol,odt_interfacejava]) then
  4593. inherited;
  4594. if (oo_is_forward in objectoptions) then
  4595. begin
  4596. { ok, in future, the forward can be resolved }
  4597. Message1(sym_e_class_forward_not_resolved,objrealname^);
  4598. exclude(objectoptions,oo_is_forward);
  4599. end;
  4600. end;
  4601. { true if prot implements d (or if they are equal) }
  4602. function is_related_interface_multiple(prot: tobjectdef; d : tdef) : boolean;
  4603. var
  4604. i : longint;
  4605. begin
  4606. { objcprotocols have multiple inheritance, all protocols from which
  4607. the current protocol inherits are stored in implementedinterfaces }
  4608. result:=prot=d;
  4609. if result then
  4610. exit;
  4611. for i:=0 to prot.ImplementedInterfaces.count-1 do
  4612. begin
  4613. result:=is_related_interface_multiple(TImplementedInterface(prot.ImplementedInterfaces[i]).intfdef,d);
  4614. if result then
  4615. exit;
  4616. end;
  4617. end;
  4618. { true, if self inherits from d (or if they are equal) }
  4619. function tobjectdef.is_related(d : tdef) : boolean;
  4620. var
  4621. hp : tobjectdef;
  4622. realself: tobjectdef;
  4623. begin
  4624. if (d.typ=objectdef) then
  4625. d:=find_real_class_definition(tobjectdef(d),false);
  4626. realself:=find_real_class_definition(self,false);
  4627. if realself=d then
  4628. begin
  4629. is_related:=true;
  4630. exit;
  4631. end;
  4632. if (d.typ<>objectdef) then
  4633. begin
  4634. is_related:=false;
  4635. exit;
  4636. end;
  4637. { Objective-C protocols and Java interfaces can use multiple
  4638. inheritance }
  4639. if (objecttype in [odt_objcprotocol,odt_interfacejava]) then
  4640. begin
  4641. is_related:=is_related_interface_multiple(realself,d);
  4642. exit
  4643. end;
  4644. { formally declared Objective-C and Java classes match Objective-C/Java
  4645. classes with the same name. In case of Java, the package must also
  4646. match}
  4647. if (objecttype in [odt_objcclass,odt_javaclass]) and
  4648. (tobjectdef(d).objecttype=objecttype) and
  4649. ((oo_is_formal in objectoptions) or
  4650. (oo_is_formal in tobjectdef(d).objectoptions)) and
  4651. (objrealname^=tobjectdef(d).objrealname^) then
  4652. begin
  4653. { check package name for Java }
  4654. if objecttype=odt_objcclass then
  4655. is_related:=true
  4656. else
  4657. begin
  4658. is_related:=
  4659. assigned(import_lib)=assigned(tobjectdef(d).import_lib);
  4660. if is_related and
  4661. assigned(import_lib) then
  4662. is_related:=import_lib^=tobjectdef(d).import_lib^;
  4663. end;
  4664. exit;
  4665. end;
  4666. hp:=realself.childof;
  4667. while assigned(hp) do
  4668. begin
  4669. if hp=d then
  4670. begin
  4671. is_related:=true;
  4672. exit;
  4673. end;
  4674. hp:=hp.childof;
  4675. end;
  4676. is_related:=false;
  4677. end;
  4678. function tobjectdef.find_destructor: tprocdef;
  4679. var
  4680. objdef: tobjectdef;
  4681. begin
  4682. objdef:=self;
  4683. while assigned(objdef) do
  4684. begin
  4685. result:=objdef.find_procdef_bytype(potype_destructor);
  4686. if assigned(result) then
  4687. exit;
  4688. objdef:=objdef.childof;
  4689. end;
  4690. result:=nil;
  4691. end;
  4692. function tobjectdef.implements_any_interfaces: boolean;
  4693. begin
  4694. result := (ImplementedInterfaces.Count > 0) or
  4695. (assigned(childof) and childof.implements_any_interfaces);
  4696. end;
  4697. function tobjectdef.size : asizeint;
  4698. begin
  4699. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  4700. result:=sizeof(pint)
  4701. else
  4702. result:=tObjectSymtable(symtable).datasize;
  4703. end;
  4704. function tobjectdef.alignment:shortint;
  4705. begin
  4706. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  4707. alignment:=sizeof(pint)
  4708. else
  4709. alignment:=tObjectSymtable(symtable).recordalignment;
  4710. end;
  4711. function tobjectdef.vmtmethodoffset(index:longint):longint;
  4712. begin
  4713. { for offset of methods for classes, see rtl/inc/objpash.inc }
  4714. case objecttype of
  4715. odt_class:
  4716. { the +2*sizeof(pint) is size and -size }
  4717. vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint);
  4718. odt_helper,
  4719. odt_objcclass,
  4720. odt_objcprotocol:
  4721. vmtmethodoffset:=0;
  4722. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  4723. vmtmethodoffset:=index*sizeof(pint);
  4724. odt_javaclass,
  4725. odt_interfacejava:
  4726. { invalid }
  4727. vmtmethodoffset:=-1;
  4728. else
  4729. {$ifdef WITHDMT}
  4730. vmtmethodoffset:=(index+4)*sizeof(pint);
  4731. {$else WITHDMT}
  4732. vmtmethodoffset:=(index+3)*sizeof(pint);
  4733. {$endif WITHDMT}
  4734. end;
  4735. end;
  4736. function tobjectdef.vmt_mangledname : string;
  4737. begin
  4738. if not(oo_has_vmt in objectoptions) then
  4739. Message1(parser_n_object_has_no_vmt,objrealname^);
  4740. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  4741. end;
  4742. function tobjectdef.needs_inittable : boolean;
  4743. begin
  4744. case objecttype of
  4745. odt_helper,
  4746. odt_class :
  4747. needs_inittable:=false;
  4748. odt_dispinterface,
  4749. odt_interfacecom:
  4750. needs_inittable:=true;
  4751. odt_interfacecorba:
  4752. needs_inittable:=is_related(interface_iunknown);
  4753. odt_object:
  4754. needs_inittable:=tObjectSymtable(symtable).needs_init_final;
  4755. odt_cppclass,
  4756. odt_objcclass,
  4757. odt_objcprotocol,
  4758. odt_javaclass,
  4759. odt_interfacejava:
  4760. needs_inittable:=false;
  4761. else
  4762. internalerror(200108267);
  4763. end;
  4764. end;
  4765. function tobjectdef.rtti_mangledname(rt: trttitype): string;
  4766. begin
  4767. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  4768. result:=inherited rtti_mangledname(rt)
  4769. else
  4770. begin
  4771. { necessary in case of a dynamic array of nsobject, or
  4772. if an nsobject field appears in a record that needs
  4773. init/finalisation }
  4774. if rt=initrtti then
  4775. begin
  4776. result:=voidpointertype.rtti_mangledname(rt);
  4777. exit;
  4778. end;
  4779. if not(target_info.system in systems_objc_nfabi) then
  4780. begin
  4781. result:=target_asm.labelprefix;
  4782. case objecttype of
  4783. odt_objcclass:
  4784. begin
  4785. case rt of
  4786. objcclassrtti:
  4787. if not(oo_is_classhelper in objectoptions) then
  4788. result:=result+'_OBJC_CLASS_'
  4789. else
  4790. result:=result+'_OBJC_CATEGORY_';
  4791. objcmetartti:
  4792. if not(oo_is_classhelper in objectoptions) then
  4793. result:=result+'_OBJC_METACLASS_'
  4794. else
  4795. internalerror(2009111511);
  4796. else
  4797. internalerror(2009092302);
  4798. end;
  4799. end;
  4800. odt_objcprotocol:
  4801. result:=result+'_OBJC_PROTOCOL_';
  4802. end;
  4803. end
  4804. else
  4805. begin
  4806. case objecttype of
  4807. odt_objcclass:
  4808. begin
  4809. if (oo_is_classhelper in objectoptions) and
  4810. (rt<>objcclassrtti) then
  4811. internalerror(2009111512);
  4812. case rt of
  4813. objcclassrtti:
  4814. if not(oo_is_classhelper in objectoptions) then
  4815. result:='_OBJC_CLASS_$_'
  4816. else
  4817. result:='_OBJC_$_CATEGORY_';
  4818. objcmetartti:
  4819. result:='_OBJC_METACLASS_$_';
  4820. objcclassrortti:
  4821. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  4822. objcmetarortti:
  4823. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  4824. else
  4825. internalerror(2009092303);
  4826. end;
  4827. end;
  4828. odt_objcprotocol:
  4829. begin
  4830. result:=lower(target_asm.labelprefix);
  4831. case rt of
  4832. objcclassrtti:
  4833. result:=result+'_OBJC_PROTOCOL_$_';
  4834. objcmetartti:
  4835. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  4836. else
  4837. internalerror(2009092501);
  4838. end;
  4839. end;
  4840. end;
  4841. end;
  4842. result:=result+objextname^;
  4843. end;
  4844. end;
  4845. function tobjectdef.members_need_inittable : boolean;
  4846. begin
  4847. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  4848. end;
  4849. function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  4850. var
  4851. ImplIntf : TImplementedInterface;
  4852. i : longint;
  4853. begin
  4854. result:=nil;
  4855. if not assigned(ImplementedInterfaces) then
  4856. exit;
  4857. for i:=0 to ImplementedInterfaces.Count-1 do
  4858. begin
  4859. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4860. if ImplIntf.intfdef=aintfdef then
  4861. begin
  4862. result:=ImplIntf;
  4863. exit;
  4864. end;
  4865. end;
  4866. end;
  4867. function tobjectdef.is_publishable : boolean;
  4868. begin
  4869. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  4870. end;
  4871. function tobjectdef.get_next_dispid: longint;
  4872. begin
  4873. inc(fcurrent_dispid);
  4874. result:=fcurrent_dispid;
  4875. end;
  4876. function tobjectdef.search_enumerator_get: tprocdef;
  4877. begin
  4878. result:=inherited;
  4879. if not assigned(result) and assigned(childof) then
  4880. result:=childof.search_enumerator_get;
  4881. end;
  4882. function tobjectdef.search_enumerator_move: tprocdef;
  4883. begin
  4884. result:=inherited;
  4885. if not assigned(result) and assigned(childof) then
  4886. result:=childof.search_enumerator_move;
  4887. end;
  4888. function tobjectdef.search_enumerator_current: tsym;
  4889. begin
  4890. result:=inherited;
  4891. if not assigned(result) and assigned(childof) then
  4892. result:=childof.search_enumerator_current;
  4893. end;
  4894. procedure tobjectdef.register_created_classref_type;
  4895. begin
  4896. if not classref_created_in_current_module then
  4897. begin
  4898. classref_created_in_current_module:=true;
  4899. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  4900. end;
  4901. end;
  4902. procedure tobjectdef.register_created_object_type;
  4903. begin
  4904. if not created_in_current_module then
  4905. begin
  4906. created_in_current_module:=true;
  4907. current_module.wpoinfo.addcreatedobjtype(self);
  4908. end;
  4909. end;
  4910. procedure tobjectdef.register_maybe_created_object_type;
  4911. begin
  4912. { if we know it has been created for sure, no need
  4913. to also record that it maybe can be created in
  4914. this module
  4915. }
  4916. if not (created_in_current_module) and
  4917. not (maybe_created_in_current_module) then
  4918. begin
  4919. maybe_created_in_current_module:=true;
  4920. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  4921. end;
  4922. end;
  4923. procedure tobjectdef.register_vmt_call(index: longint);
  4924. begin
  4925. if (is_object(self) or is_class(self)) then
  4926. current_module.wpoinfo.addcalledvmtentry(self,index);
  4927. end;
  4928. procedure check_and_finish_msg(data: tobject; arg: pointer);
  4929. var
  4930. def: tdef absolute data;
  4931. pd: tprocdef absolute data;
  4932. i,
  4933. paracount: longint;
  4934. begin
  4935. if (def.typ=procdef) then
  4936. begin
  4937. { add all messages also under a dummy name to the symtable in
  4938. which the objcclass/protocol/category is declared, so they can
  4939. be called via id.<name>
  4940. }
  4941. create_class_helper_for_procdef(pd,nil);
  4942. { we have to wait until now to set the mangled name because it
  4943. depends on the (possibly external) class name, which is defined
  4944. at the very end. }
  4945. if not(po_msgstr in pd.procoptions) then
  4946. begin
  4947. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  4948. { recover to avoid internalerror later on }
  4949. include(pd.procoptions,po_msgstr);
  4950. pd.messageinf.str:=stringdup('MissingDeclaration');
  4951. end;
  4952. { Mangled name is already set in case this is a copy of
  4953. another type. }
  4954. if not(po_has_mangledname in pd.procoptions) then
  4955. begin
  4956. { check whether the number of formal parameters is correct,
  4957. and whether they have valid Objective-C types }
  4958. paracount:=0;
  4959. for i:=1 to length(pd.messageinf.str^) do
  4960. if pd.messageinf.str^[i]=':' then
  4961. inc(paracount);
  4962. for i:=0 to pd.paras.count-1 do
  4963. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  4964. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  4965. dec(paracount);
  4966. if (paracount<>0) then
  4967. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  4968. pd.setmangledname(pd.objcmangledname);
  4969. end
  4970. else
  4971. { all checks already done }
  4972. exit;
  4973. if not(oo_is_external in pd.struct.objectoptions) then
  4974. begin
  4975. if (po_varargs in pd.procoptions) then
  4976. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  4977. else
  4978. begin
  4979. { check for "array of const" parameters }
  4980. for i:=0 to pd.parast.symlist.count-1 do
  4981. begin
  4982. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  4983. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  4984. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  4985. end;
  4986. end;
  4987. end;
  4988. end;
  4989. end;
  4990. procedure mark_private_fields_used(data: tobject; arg: pointer);
  4991. var
  4992. sym: tsym absolute data;
  4993. begin
  4994. if (sym.typ=fieldvarsym) and
  4995. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  4996. sym.IncRefCount;
  4997. end;
  4998. procedure tobjectdef.finish_objc_data;
  4999. begin
  5000. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  5001. if (oo_is_external in objectoptions) then
  5002. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  5003. end;
  5004. procedure verify_objc_vardef(data: tobject; arg: pointer);
  5005. var
  5006. sym: tabstractvarsym absolute data;
  5007. res: pboolean absolute arg;
  5008. founderrordef: tdef;
  5009. begin
  5010. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  5011. exit;
  5012. if (sym.typ=paravarsym) and
  5013. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  5014. is_array_of_const(tparavarsym(sym).vardef)) then
  5015. exit;
  5016. if not objcchecktype(sym.vardef,founderrordef) then
  5017. begin
  5018. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5019. res^:=false;
  5020. end;
  5021. end;
  5022. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  5023. var
  5024. def: tdef absolute data;
  5025. res: pboolean absolute arg;
  5026. founderrordef: tdef;
  5027. begin
  5028. if (def.typ<>procdef) then
  5029. exit;
  5030. { check parameter types for validity }
  5031. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  5032. { check the result type for validity }
  5033. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  5034. begin
  5035. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5036. res^:=false;
  5037. end;
  5038. end;
  5039. function tobjectdef.check_objc_types: boolean;
  5040. begin
  5041. { done in separate step from finish_objc_data, because when
  5042. finish_objc_data is called, not all forwarddefs have been resolved
  5043. yet and we need to know all types here }
  5044. result:=true;
  5045. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  5046. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  5047. end;
  5048. procedure do_cpp_import_info(data: tobject; arg: pointer);
  5049. var
  5050. def: tdef absolute data;
  5051. pd: tprocdef absolute data;
  5052. begin
  5053. if (def.typ=procdef) then
  5054. begin
  5055. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  5056. if (oo_is_external in pd.struct.objectoptions) then
  5057. begin
  5058. { copied from psub.read_proc }
  5059. if assigned(tobjectdef(pd.struct).import_lib) then
  5060. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  5061. else
  5062. begin
  5063. { add import name to external list for DLL scanning }
  5064. if tf_has_dllscanner in target_info.flags then
  5065. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  5066. end;
  5067. end;
  5068. end;
  5069. end;
  5070. procedure tobjectdef.finish_cpp_data;
  5071. begin
  5072. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  5073. end;
  5074. {****************************************************************************
  5075. TImplementedInterface
  5076. ****************************************************************************}
  5077. constructor TImplementedInterface.create(aintf: tobjectdef);
  5078. begin
  5079. inherited create;
  5080. intfdef:=aintf;
  5081. IOffset:=-1;
  5082. IType:=etStandard;
  5083. NameMappings:=nil;
  5084. procdefs:=nil;
  5085. end;
  5086. constructor TImplementedInterface.create_deref(d:tderef);
  5087. begin
  5088. inherited create;
  5089. intfdef:=nil;
  5090. intfdefderef:=d;
  5091. IOffset:=-1;
  5092. IType:=etStandard;
  5093. NameMappings:=nil;
  5094. procdefs:=nil;
  5095. end;
  5096. destructor TImplementedInterface.destroy;
  5097. var
  5098. i : longint;
  5099. mappedname : pshortstring;
  5100. begin
  5101. if assigned(NameMappings) then
  5102. begin
  5103. for i:=0 to NameMappings.Count-1 do
  5104. begin
  5105. mappedname:=pshortstring(NameMappings[i]);
  5106. stringdispose(mappedname);
  5107. end;
  5108. NameMappings.free;
  5109. NameMappings:=nil;
  5110. end;
  5111. if assigned(procdefs) then
  5112. begin
  5113. procdefs.free;
  5114. procdefs:=nil;
  5115. end;
  5116. inherited destroy;
  5117. end;
  5118. procedure TImplementedInterface.buildderef;
  5119. begin
  5120. intfdefderef.build(intfdef);
  5121. end;
  5122. procedure TImplementedInterface.deref;
  5123. begin
  5124. intfdef:=tobjectdef(intfdefderef.resolve);
  5125. end;
  5126. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  5127. begin
  5128. if not assigned(NameMappings) then
  5129. NameMappings:=TFPHashList.Create;
  5130. NameMappings.Add(origname,stringdup(newname));
  5131. end;
  5132. function TImplementedInterface.GetMapping(const origname: string):string;
  5133. var
  5134. mappedname : pshortstring;
  5135. begin
  5136. result:='';
  5137. if not assigned(NameMappings) then
  5138. exit;
  5139. mappedname:=PShortstring(NameMappings.Find(origname));
  5140. if assigned(mappedname) then
  5141. result:=mappedname^;
  5142. end;
  5143. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  5144. begin
  5145. if not assigned(procdefs) then
  5146. procdefs:=TFPObjectList.Create(false);
  5147. { duplicate entries must be stored, because multiple }
  5148. { interfaces can declare methods with the same name }
  5149. { and all of these get their own VMT entry }
  5150. procdefs.Add(pd);
  5151. end;
  5152. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  5153. var
  5154. i : longint;
  5155. begin
  5156. result:=false;
  5157. { interfaces being implemented through delegation are not mergable (FK) }
  5158. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  5159. exit;
  5160. weight:=0;
  5161. { empty interface is mergeable }
  5162. if ProcDefs.Count=0 then
  5163. begin
  5164. result:=true;
  5165. exit;
  5166. end;
  5167. { The interface to merge must at least the number of
  5168. procedures of this interface }
  5169. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  5170. exit;
  5171. for i:=0 to ProcDefs.Count-1 do
  5172. begin
  5173. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  5174. exit;
  5175. end;
  5176. weight:=ProcDefs.Count;
  5177. result:=true;
  5178. end;
  5179. function TImplementedInterface.getcopy:TImplementedInterface;
  5180. begin
  5181. Result:=TImplementedInterface.Create(nil);
  5182. { 1) the procdefs list will be freed once for each copy
  5183. 2) since the procdefs list owns its elements, those will also be freed for each copy
  5184. 3) idem for the name mappings
  5185. }
  5186. { warning: this is completely wrong on so many levels...
  5187. Move(pointer(self)^,pointer(result)^,InstanceSize);
  5188. We need to make clean copies of the different fields
  5189. this is not implemented yet, and thus we generate an internal
  5190. error instead PM 2011-06-14 }
  5191. internalerror(2011061401);
  5192. end;
  5193. {****************************************************************************
  5194. TFORWARDDEF
  5195. ****************************************************************************}
  5196. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  5197. begin
  5198. inherited create(forwarddef);
  5199. tosymname:=stringdup(s);
  5200. forwardpos:=pos;
  5201. end;
  5202. function tforwarddef.GetTypeName:string;
  5203. begin
  5204. GetTypeName:='unresolved forward to '+tosymname^;
  5205. end;
  5206. destructor tforwarddef.destroy;
  5207. begin
  5208. stringdispose(tosymname);
  5209. inherited destroy;
  5210. end;
  5211. function tforwarddef.getcopy:tstoreddef;
  5212. begin
  5213. result:=tforwarddef.create(tosymname^, forwardpos);
  5214. end;
  5215. {****************************************************************************
  5216. TUNDEFINEDDEF
  5217. ****************************************************************************}
  5218. constructor tundefineddef.create;
  5219. begin
  5220. inherited create(undefineddef);
  5221. end;
  5222. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  5223. begin
  5224. inherited ppuload(undefineddef,ppufile);
  5225. end;
  5226. function tundefineddef.GetTypeName:string;
  5227. begin
  5228. GetTypeName:='<undefined type>';
  5229. end;
  5230. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  5231. begin
  5232. inherited ppuwrite(ppufile);
  5233. ppufile.writeentry(ibundefineddef);
  5234. end;
  5235. {****************************************************************************
  5236. TERRORDEF
  5237. ****************************************************************************}
  5238. constructor terrordef.create;
  5239. begin
  5240. inherited create(errordef);
  5241. { prevent consecutive faults }
  5242. savesize:=1;
  5243. end;
  5244. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  5245. begin
  5246. { Can't write errordefs to ppu }
  5247. internalerror(200411063);
  5248. end;
  5249. function terrordef.GetTypeName:string;
  5250. begin
  5251. GetTypeName:='<erroneous type>';
  5252. end;
  5253. function terrordef.getmangledparaname:string;
  5254. begin
  5255. getmangledparaname:='error';
  5256. end;
  5257. {****************************************************************************
  5258. Definition Helpers
  5259. ****************************************************************************}
  5260. function is_interfacecom(def: tdef): boolean;
  5261. begin
  5262. is_interfacecom:=
  5263. assigned(def) and
  5264. (def.typ=objectdef) and
  5265. (tobjectdef(def).objecttype=odt_interfacecom);
  5266. end;
  5267. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  5268. begin
  5269. is_interfacecom_or_dispinterface:=
  5270. assigned(def) and
  5271. (def.typ=objectdef) and
  5272. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  5273. end;
  5274. function is_any_interface_kind(def: tdef): boolean;
  5275. begin
  5276. result:=
  5277. assigned(def) and
  5278. (def.typ=objectdef) and
  5279. ((tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba,odt_interfacejava,odt_objcprotocol]) or
  5280. is_objccategory(def));
  5281. end;
  5282. function is_interfacecorba(def: tdef): boolean;
  5283. begin
  5284. is_interfacecorba:=
  5285. assigned(def) and
  5286. (def.typ=objectdef) and
  5287. (tobjectdef(def).objecttype=odt_interfacecorba);
  5288. end;
  5289. function is_interface(def: tdef): boolean;
  5290. begin
  5291. is_interface:=
  5292. assigned(def) and
  5293. (def.typ=objectdef) and
  5294. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  5295. end;
  5296. function is_dispinterface(def: tdef): boolean;
  5297. begin
  5298. result:=
  5299. assigned(def) and
  5300. (def.typ=objectdef) and
  5301. (tobjectdef(def).objecttype=odt_dispinterface);
  5302. end;
  5303. function is_class(def: tdef): boolean;
  5304. begin
  5305. is_class:=
  5306. assigned(def) and
  5307. (def.typ=objectdef) and
  5308. (tobjectdef(def).objecttype=odt_class);
  5309. end;
  5310. function is_object(def: tdef): boolean;
  5311. begin
  5312. is_object:=
  5313. assigned(def) and
  5314. (def.typ=objectdef) and
  5315. (tobjectdef(def).objecttype=odt_object);
  5316. end;
  5317. function is_cppclass(def: tdef): boolean;
  5318. begin
  5319. is_cppclass:=
  5320. assigned(def) and
  5321. (def.typ=objectdef) and
  5322. (tobjectdef(def).objecttype=odt_cppclass);
  5323. end;
  5324. function is_objcclass(def: tdef): boolean;
  5325. begin
  5326. is_objcclass:=
  5327. assigned(def) and
  5328. (def.typ=objectdef) and
  5329. (tobjectdef(def).objecttype=odt_objcclass);
  5330. end;
  5331. function is_objectpascal_helper(def: tdef): boolean;
  5332. begin
  5333. result:=
  5334. assigned(def) and
  5335. (def.typ=objectdef) and
  5336. (tobjectdef(def).objecttype=odt_helper);
  5337. end;
  5338. function is_objcclassref(def: tdef): boolean;
  5339. begin
  5340. is_objcclassref:=
  5341. assigned(def) and
  5342. (def.typ=classrefdef) and
  5343. is_objcclass(tclassrefdef(def).pointeddef);
  5344. end;
  5345. function is_objcprotocol(def: tdef): boolean;
  5346. begin
  5347. result:=
  5348. assigned(def) and
  5349. (def.typ=objectdef) and
  5350. (tobjectdef(def).objecttype=odt_objcprotocol);
  5351. end;
  5352. function is_objccategory(def: tdef): boolean;
  5353. begin
  5354. result:=
  5355. assigned(def) and
  5356. (def.typ=objectdef) and
  5357. { if used as a forward type }
  5358. ((tobjectdef(def).objecttype=odt_objccategory) or
  5359. { if used as after it has been resolved }
  5360. ((tobjectdef(def).objecttype=odt_objcclass) and
  5361. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5362. end;
  5363. function is_objc_class_or_protocol(def: tdef): boolean;
  5364. begin
  5365. result:=
  5366. assigned(def) and
  5367. (def.typ=objectdef) and
  5368. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  5369. end;
  5370. function is_objc_protocol_or_category(def: tdef): boolean;
  5371. begin
  5372. result:=
  5373. assigned(def) and
  5374. (def.typ=objectdef) and
  5375. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  5376. ((tobjectdef(def).objecttype = odt_objcclass) and
  5377. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5378. end;
  5379. function is_classhelper(def: tdef): boolean;
  5380. begin
  5381. result:=
  5382. is_objectpascal_helper(def) or
  5383. is_objccategory(def);
  5384. end;
  5385. function is_class_or_interface(def: tdef): boolean;
  5386. begin
  5387. result:=
  5388. assigned(def) and
  5389. (def.typ=objectdef) and
  5390. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  5391. end;
  5392. function is_class_or_interface_or_objc(def: tdef): boolean;
  5393. begin
  5394. result:=
  5395. assigned(def) and
  5396. (def.typ=objectdef) and
  5397. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  5398. end;
  5399. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  5400. begin
  5401. result:=
  5402. assigned(def) and
  5403. (def.typ=objectdef) and
  5404. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  5405. end;
  5406. function is_class_or_interface_or_object(def: tdef): boolean;
  5407. begin
  5408. result:=
  5409. assigned(def) and
  5410. (def.typ=objectdef) and
  5411. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  5412. end;
  5413. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  5414. begin
  5415. result:=
  5416. assigned(def) and
  5417. (def.typ=objectdef) and
  5418. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  5419. end;
  5420. function is_implicit_pointer_object_type(def: tdef): boolean;
  5421. begin
  5422. result:=
  5423. assigned(def) and
  5424. (((def.typ=objectdef) and
  5425. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
  5426. ((target_info.system=system_jvm_java32) and
  5427. (def.typ=recorddef)));
  5428. end;
  5429. function is_class_or_object(def: tdef): boolean;
  5430. begin
  5431. result:=
  5432. assigned(def) and
  5433. (def.typ=objectdef) and
  5434. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  5435. end;
  5436. function is_record(def: tdef): boolean;
  5437. begin
  5438. result:=
  5439. assigned(def) and
  5440. (def.typ=recorddef);
  5441. end;
  5442. function is_javaclass(def: tdef): boolean;
  5443. begin
  5444. result:=
  5445. assigned(def) and
  5446. (def.typ=objectdef) and
  5447. (tobjectdef(def).objecttype=odt_javaclass);
  5448. end;
  5449. function is_javainterface(def: tdef): boolean;
  5450. begin
  5451. result:=
  5452. assigned(def) and
  5453. (def.typ=objectdef) and
  5454. (tobjectdef(def).objecttype=odt_interfacejava);
  5455. end;
  5456. function is_java_class_or_interface(def: tdef): boolean;
  5457. begin
  5458. result:=
  5459. assigned(def) and
  5460. (def.typ=objectdef) and
  5461. (tobjectdef(def).objecttype in [odt_javaclass,odt_interfacejava]);
  5462. end;
  5463. procedure loadobjctypes;
  5464. begin
  5465. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  5466. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  5467. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  5468. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  5469. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  5470. end;
  5471. procedure maybeloadcocoatypes;
  5472. var
  5473. tsym: ttypesym;
  5474. begin
  5475. if assigned(objc_fastenumeration) then
  5476. exit;
  5477. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONPROTOCOL',false);
  5478. if assigned(tsym) then
  5479. objc_fastenumeration:=tobjectdef(tsym.typedef)
  5480. else
  5481. objc_fastenumeration:=nil;
  5482. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONSTATE',false);
  5483. if assigned(tsym) then
  5484. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  5485. else
  5486. objc_fastenumerationstate:=nil;
  5487. end;
  5488. function use_vectorfpu(def : tdef) : boolean;
  5489. begin
  5490. {$ifdef x86}
  5491. {$define use_vectorfpuimplemented}
  5492. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  5493. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  5494. {$endif x86}
  5495. {$ifdef arm}
  5496. {$define use_vectorfpuimplemented}
  5497. use_vectorfpu:=(current_settings.fputype in vfp_scalar);
  5498. {$endif arm}
  5499. {$ifndef use_vectorfpuimplemented}
  5500. use_vectorfpu:=false;
  5501. {$endif}
  5502. end;
  5503. end.