symdef.pas 177 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670
  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,
  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 = class(tdef)
  42. protected
  43. typesymderef : tderef;
  44. public
  45. { persistent (available across units) rtti and init tables }
  46. rttitablesym,
  47. inittablesym : tsym; {trttisym}
  48. rttitablesymderef,
  49. inittablesymderef : tderef;
  50. { local (per module) rtti and init tables }
  51. localrttilab : array[trttitype] of tasmlabel;
  52. {$ifdef EXTDEBUG}
  53. fileinfo : tfileposinfo;
  54. {$endif}
  55. { generic support }
  56. genericdef : tstoreddef;
  57. genericdefderef : tderef;
  58. generictokenbuf : tdynamicarray;
  59. constructor create(dt:tdeftype);
  60. constructor ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  61. destructor destroy;override;
  62. procedure reset;virtual;
  63. function getcopy : tstoreddef;virtual;
  64. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  65. procedure buildderef;override;
  66. procedure buildderefimpl;override;
  67. procedure deref;override;
  68. procedure derefimpl;override;
  69. function size:aint;override;
  70. function getvardef:longint;override;
  71. function alignment:shortint;override;
  72. function is_publishable : boolean;override;
  73. function needs_inittable : boolean;override;
  74. { rtti generation }
  75. procedure write_rtti_name;
  76. procedure write_rtti_data(rt:trttitype);virtual;
  77. procedure write_child_rtti_data(rt:trttitype);virtual;
  78. function get_rtti_label(rt:trttitype):tasmsymbol;
  79. { regvars }
  80. function is_intregable : boolean;
  81. function is_fpuregable : boolean;
  82. { generics }
  83. procedure initgeneric;
  84. private
  85. savesize : aint;
  86. end;
  87. tfiletyp = (ft_text,ft_typed,ft_untyped);
  88. tfiledef = class(tstoreddef)
  89. filetyp : tfiletyp;
  90. typedfiledef : tdef;
  91. typedfiledefderef : tderef;
  92. constructor createtext;
  93. constructor createuntyped;
  94. constructor createtyped(def : tdef);
  95. constructor ppuload(ppufile:tcompilerppufile);
  96. function getcopy : tstoreddef;override;
  97. procedure ppuwrite(ppufile:tcompilerppufile);override;
  98. procedure buildderef;override;
  99. procedure deref;override;
  100. function GetTypeName:string;override;
  101. function getmangledparaname:string;override;
  102. procedure setsize;
  103. end;
  104. tvariantdef = class(tstoreddef)
  105. varianttype : tvarianttype;
  106. constructor create(v : tvarianttype);
  107. constructor ppuload(ppufile:tcompilerppufile);
  108. function getcopy : tstoreddef;override;
  109. function GetTypeName:string;override;
  110. procedure ppuwrite(ppufile:tcompilerppufile);override;
  111. procedure setsize;
  112. function is_publishable : boolean;override;
  113. function needs_inittable : boolean;override;
  114. procedure write_rtti_data(rt:trttitype);override;
  115. end;
  116. tformaldef = class(tstoreddef)
  117. constructor create;
  118. constructor ppuload(ppufile:tcompilerppufile);
  119. procedure ppuwrite(ppufile:tcompilerppufile);override;
  120. function GetTypeName:string;override;
  121. end;
  122. tforwarddef = class(tstoreddef)
  123. tosymname : pshortstring;
  124. forwardpos : tfileposinfo;
  125. constructor create(const s:string;const pos : tfileposinfo);
  126. destructor destroy;override;
  127. function GetTypeName:string;override;
  128. end;
  129. tundefineddef = class(tstoreddef)
  130. constructor create;
  131. constructor ppuload(ppufile:tcompilerppufile);
  132. procedure ppuwrite(ppufile:tcompilerppufile);override;
  133. function GetTypeName:string;override;
  134. end;
  135. terrordef = class(tstoreddef)
  136. constructor create;
  137. procedure ppuwrite(ppufile:tcompilerppufile);override;
  138. function GetTypeName:string;override;
  139. function getmangledparaname : string;override;
  140. end;
  141. tabstractpointerdef = class(tstoreddef)
  142. pointeddef : tdef;
  143. pointeddefderef : tderef;
  144. constructor create(dt:tdeftype;def:tdef);
  145. constructor ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  146. procedure ppuwrite(ppufile:tcompilerppufile);override;
  147. procedure buildderef;override;
  148. procedure deref;override;
  149. end;
  150. tpointerdef = class(tabstractpointerdef)
  151. is_far : boolean;
  152. constructor create(def:tdef);
  153. constructor createfar(def:tdef);
  154. function getcopy : tstoreddef;override;
  155. constructor ppuload(ppufile:tcompilerppufile);
  156. procedure ppuwrite(ppufile:tcompilerppufile);override;
  157. function GetTypeName:string;override;
  158. end;
  159. tabstractrecorddef= class(tstoreddef)
  160. private
  161. Count : integer;
  162. FRTTIType : trttitype;
  163. procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
  164. procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
  165. procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
  166. public
  167. symtable : tsymtable;
  168. procedure reset;override;
  169. function getsymtable(t:tgetsymtable):tsymtable;override;
  170. function is_packed:boolean;
  171. end;
  172. trecorddef = class(tabstractrecorddef)
  173. public
  174. isunion : boolean;
  175. constructor create(p : tsymtable);
  176. constructor ppuload(ppufile:tcompilerppufile);
  177. destructor destroy;override;
  178. function getcopy : tstoreddef;override;
  179. procedure ppuwrite(ppufile:tcompilerppufile);override;
  180. procedure buildderef;override;
  181. procedure deref;override;
  182. function size:aint;override;
  183. function alignment : shortint;override;
  184. function padalignment: shortint;
  185. function GetTypeName:string;override;
  186. { debug }
  187. function needs_inittable : boolean;override;
  188. { rtti }
  189. procedure write_child_rtti_data(rt:trttitype);override;
  190. procedure write_rtti_data(rt:trttitype);override;
  191. end;
  192. tprocdef = class;
  193. tobjectdef = class;
  194. timplementedinterfaces = class;
  195. timplintfentry = class(TNamedIndexItem)
  196. intf : tobjectdef;
  197. intfderef : tderef;
  198. ioffset : longint;
  199. implindex : longint;
  200. namemappings : tdictionary;
  201. procdefs : TIndexArray;
  202. constructor create(aintf: tobjectdef);
  203. constructor create_deref(d:tderef);
  204. destructor destroy; override;
  205. end;
  206. tobjectdef = class(tabstractrecorddef)
  207. private
  208. procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
  209. procedure collect_published_properties(sym:tnamedindexitem;arg:pointer);
  210. procedure write_property_info(sym : tnamedindexitem;arg:pointer);
  211. procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  212. procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
  213. procedure writefields(sym:tnamedindexitem;arg:pointer);
  214. public
  215. childof : tobjectdef;
  216. childofderef : tderef;
  217. objname,
  218. objrealname : pshortstring;
  219. objectoptions : tobjectoptions;
  220. { to be able to have a variable vmt position }
  221. { and no vmt field for objects without virtuals }
  222. vmt_offset : longint;
  223. writing_class_record_dbginfo : boolean;
  224. objecttype : tobjectdeftype;
  225. iidguid: pguid;
  226. iidstr: pshortstring;
  227. iitype: tinterfaceentrytype;
  228. iioffset: longint;
  229. lastvtableindex: longint;
  230. { store implemented interfaces defs and name mappings }
  231. implementedinterfaces: timplementedinterfaces;
  232. constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  233. constructor ppuload(ppufile:tcompilerppufile);
  234. destructor destroy;override;
  235. function getcopy : tstoreddef;override;
  236. procedure ppuwrite(ppufile:tcompilerppufile);override;
  237. function GetTypeName:string;override;
  238. procedure buildderef;override;
  239. procedure deref;override;
  240. function getparentdef:tdef;override;
  241. function size : aint;override;
  242. function alignment:shortint;override;
  243. function vmtmethodoffset(index:longint):longint;
  244. function members_need_inittable : boolean;
  245. { this should be called when this class implements an interface }
  246. procedure prepareguid;
  247. function is_publishable : boolean;override;
  248. function needs_inittable : boolean;override;
  249. function vmt_mangledname : string;
  250. function rtti_name : string;
  251. procedure check_forwards;
  252. function is_related(d : tdef) : boolean;override;
  253. procedure insertvmt;
  254. procedure set_parent(c : tobjectdef);
  255. function searchdestructor : tprocdef;
  256. { rtti }
  257. procedure write_child_rtti_data(rt:trttitype);override;
  258. procedure write_rtti_data(rt:trttitype);override;
  259. function generate_field_table : tasmlabel;
  260. end;
  261. timplementedinterfaces = class
  262. constructor create;
  263. destructor destroy; override;
  264. function count: longint;
  265. function interfaces(intfindex: longint): tobjectdef;
  266. function interfacesderef(intfindex: longint): tderef;
  267. function ioffsets(intfindex: longint): longint;
  268. procedure setioffsets(intfindex,iofs:longint);
  269. function implindex(intfindex:longint):longint;
  270. procedure setimplindex(intfindex,implidx:longint);
  271. function searchintf(def: tdef): longint;
  272. procedure addintf(def: tdef);
  273. procedure buildderef;
  274. procedure deref;
  275. { add interface reference loaded from ppu }
  276. procedure addintf_deref(const d:tderef;iofs:longint);
  277. procedure addintf_ioffset(d:tdef;iofs:longint);
  278. procedure clearmappings;
  279. procedure addmappings(intfindex: longint; const origname, newname: string);
  280. function getmappings(intfindex: longint; const origname: string; var nextexist: pointer): string;
  281. procedure addimplproc(intfindex: longint; procdef: tprocdef);
  282. function implproccount(intfindex: longint): longint;
  283. function implprocs(intfindex: longint; procindex: longint): tprocdef;
  284. function isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  285. private
  286. finterfaces: tindexarray;
  287. procedure checkindex(intfindex: longint);
  288. end;
  289. tclassrefdef = class(tabstractpointerdef)
  290. constructor create(def:tdef);
  291. constructor ppuload(ppufile:tcompilerppufile);
  292. procedure ppuwrite(ppufile:tcompilerppufile);override;
  293. function GetTypeName:string;override;
  294. function is_publishable : boolean;override;
  295. end;
  296. tarraydef = class(tstoreddef)
  297. lowrange,
  298. highrange : aint;
  299. rangedef : tdef;
  300. rangedefderef : tderef;
  301. arrayoptions : tarraydefoptions;
  302. protected
  303. _elementdef : tdef;
  304. _elementdefderef : tderef;
  305. procedure setelementdef(def:tdef);
  306. public
  307. function elesize : aint;
  308. function elepackedbitsize : aint;
  309. function elecount : aint;
  310. constructor create_from_pointer(def:tdef);
  311. constructor create(l,h : aint;def:tdef);
  312. constructor ppuload(ppufile:tcompilerppufile);
  313. function getcopy : tstoreddef;override;
  314. procedure ppuwrite(ppufile:tcompilerppufile);override;
  315. function GetTypeName:string;override;
  316. function getmangledparaname : string;override;
  317. procedure buildderef;override;
  318. procedure deref;override;
  319. function size : aint;override;
  320. function alignment : shortint;override;
  321. { returns the label of the range check string }
  322. function needs_inittable : boolean;override;
  323. procedure write_child_rtti_data(rt:trttitype);override;
  324. procedure write_rtti_data(rt:trttitype);override;
  325. property elementdef : tdef read _elementdef write setelementdef;
  326. end;
  327. torddef = class(tstoreddef)
  328. low,high : TConstExprInt;
  329. typ : tbasetype;
  330. constructor create(t : tbasetype;v,b : TConstExprInt);
  331. constructor ppuload(ppufile:tcompilerppufile);
  332. function getcopy : tstoreddef;override;
  333. procedure ppuwrite(ppufile:tcompilerppufile);override;
  334. function is_publishable : boolean;override;
  335. function GetTypeName:string;override;
  336. function alignment:shortint;override;
  337. procedure setsize;
  338. function packedbitsize: aint; override;
  339. function getvardef : longint;override;
  340. { rtti }
  341. procedure write_rtti_data(rt:trttitype);override;
  342. end;
  343. tfloatdef = class(tstoreddef)
  344. typ : tfloattype;
  345. constructor create(t : tfloattype);
  346. constructor ppuload(ppufile:tcompilerppufile);
  347. function getcopy : tstoreddef;override;
  348. procedure ppuwrite(ppufile:tcompilerppufile);override;
  349. function GetTypeName:string;override;
  350. function is_publishable : boolean;override;
  351. function alignment:shortint;override;
  352. procedure setsize;
  353. function getvardef:longint;override;
  354. { rtti }
  355. procedure write_rtti_data(rt:trttitype);override;
  356. end;
  357. tabstractprocdef = class(tstoreddef)
  358. { saves a definition to the return type }
  359. returndef : tdef;
  360. returndefderef : tderef;
  361. parast : tsymtable;
  362. paras : tparalist;
  363. proctypeoption : tproctypeoption;
  364. proccalloption : tproccalloption;
  365. procoptions : tprocoptions;
  366. requiredargarea : aint;
  367. { number of user visibile parameters }
  368. maxparacount,
  369. minparacount : byte;
  370. {$ifdef i386}
  371. fpu_used : longint; { how many stack fpu must be empty }
  372. {$endif i386}
  373. {$ifdef m68k}
  374. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  375. {$endif}
  376. funcretloc : array[tcallercallee] of TLocation;
  377. has_paraloc_info : boolean; { paraloc info is available }
  378. constructor create(dt:tdeftype;level:byte);
  379. constructor ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  380. destructor destroy;override;
  381. procedure ppuwrite(ppufile:tcompilerppufile);override;
  382. procedure buildderef;override;
  383. procedure deref;override;
  384. procedure releasemem;
  385. procedure calcparas;
  386. function typename_paras(showhidden:boolean): string;
  387. procedure test_if_fpu_result;
  388. function is_methodpointer:boolean;virtual;
  389. function is_addressonly:boolean;virtual;
  390. private
  391. procedure count_para(p:tnamedindexitem;arg:pointer);
  392. procedure insert_para(p:tnamedindexitem;arg:pointer);
  393. end;
  394. tprocvardef = class(tabstractprocdef)
  395. constructor create(level:byte);
  396. constructor ppuload(ppufile:tcompilerppufile);
  397. function getcopy : tstoreddef;override;
  398. procedure ppuwrite(ppufile:tcompilerppufile);override;
  399. procedure buildderef;override;
  400. procedure deref;override;
  401. function getsymtable(t:tgetsymtable):tsymtable;override;
  402. function size : aint;override;
  403. function GetTypeName:string;override;
  404. function is_publishable : boolean;override;
  405. function is_methodpointer:boolean;override;
  406. function is_addressonly:boolean;override;
  407. function getmangledparaname:string;override;
  408. { rtti }
  409. procedure write_rtti_data(rt:trttitype);override;
  410. end;
  411. tmessageinf = record
  412. case integer of
  413. 0 : (str : pshortstring);
  414. 1 : (i : longint);
  415. end;
  416. tinlininginfo = record
  417. { node tree }
  418. code : tnode;
  419. flags : tprocinfoflags;
  420. end;
  421. pinlininginfo = ^tinlininginfo;
  422. {$ifdef oldregvars}
  423. { register variables }
  424. pregvarinfo = ^tregvarinfo;
  425. tregvarinfo = record
  426. regvars : array[1..maxvarregs] of tsym;
  427. regvars_para : array[1..maxvarregs] of boolean;
  428. regvars_refs : array[1..maxvarregs] of longint;
  429. fpuregvars : array[1..maxfpuvarregs] of tsym;
  430. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  431. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  432. end;
  433. {$endif oldregvars}
  434. tprocdef = class(tabstractprocdef)
  435. private
  436. _mangledname : pshortstring;
  437. public
  438. extnumber : word;
  439. messageinf : tmessageinf;
  440. {$ifndef EXTDEBUG}
  441. { where is this function defined and what were the symbol
  442. flags, needed here because there
  443. is only one symbol for all overloaded functions
  444. EXTDEBUG has fileinfo in tdef (PFV) }
  445. fileinfo : tfileposinfo;
  446. {$endif}
  447. symoptions : tsymoptions;
  448. { symbol owning this definition }
  449. procsym : tsym;
  450. procsymderef : tderef;
  451. { alias names }
  452. aliasnames : tstringlist;
  453. { symtables }
  454. localst : tsymtable;
  455. funcretsym : tsym;
  456. funcretsymderef : tderef;
  457. { browser info }
  458. lastref,
  459. defref,
  460. lastwritten : tref;
  461. refcount : longint;
  462. _class : tobjectdef;
  463. _classderef : tderef;
  464. {$if defined(powerpc) or defined(m68k)}
  465. { library symbol for AmigaOS/MorphOS }
  466. libsym : tsym;
  467. libsymderef : tderef;
  468. {$endif powerpc or m68k}
  469. { name of the result variable to insert in the localsymtable }
  470. resultname : stringid;
  471. { true, if the procedure is only declared
  472. (forward procedure) }
  473. forwarddef,
  474. { true if the procedure is declared in the interface }
  475. interfacedef : boolean;
  476. { true if the procedure has a forward declaration }
  477. hasforward : boolean;
  478. { import info }
  479. import_dll,
  480. import_name : pshortstring;
  481. import_nr : word;
  482. { info for inlining the subroutine, if this pointer is nil,
  483. the procedure can't be inlined }
  484. inlininginfo : pinlininginfo;
  485. {$ifdef oldregvars}
  486. regvarinfo: pregvarinfo;
  487. {$endif oldregvars}
  488. { position in aasmoutput list }
  489. procstarttai,
  490. procendtai : tai;
  491. constructor create(level:byte);
  492. constructor ppuload(ppufile:tcompilerppufile);
  493. destructor destroy;override;
  494. procedure ppuwrite(ppufile:tcompilerppufile);override;
  495. procedure buildderef;override;
  496. procedure buildderefimpl;override;
  497. procedure deref;override;
  498. procedure derefimpl;override;
  499. procedure reset;override;
  500. function getsymtable(t:tgetsymtable):tsymtable;override;
  501. function GetTypeName : string;override;
  502. function mangledname : string;
  503. procedure setmangledname(const s : string);
  504. procedure load_references(ppufile:tcompilerppufile;locals:boolean);
  505. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  506. { inserts the local symbol table, if this is not
  507. no local symbol table is built. Should be called only
  508. when we are sure that a local symbol table will be required.
  509. }
  510. procedure insert_localst;
  511. function fullprocname(showhidden:boolean):string;
  512. function cplusplusmangledname : string;
  513. function is_methodpointer:boolean;override;
  514. function is_addressonly:boolean;override;
  515. function is_visible_for_object(currobjdef,contextobjdef:tobjectdef):boolean;
  516. end;
  517. { single linked list of overloaded procs }
  518. pprocdeflist = ^tprocdeflist;
  519. tprocdeflist = record
  520. def : tprocdef;
  521. defderef : tderef;
  522. next : pprocdeflist;
  523. end;
  524. tstringdef = class(tstoreddef)
  525. string_typ : tstringtype;
  526. len : aint;
  527. constructor createshort(l : byte);
  528. constructor loadshort(ppufile:tcompilerppufile);
  529. constructor createlong(l : aint);
  530. constructor loadlong(ppufile:tcompilerppufile);
  531. constructor createansi(l : aint);
  532. constructor loadansi(ppufile:tcompilerppufile);
  533. constructor createwide(l : aint);
  534. constructor loadwide(ppufile:tcompilerppufile);
  535. function getcopy : tstoreddef;override;
  536. function stringtypname:string;
  537. procedure ppuwrite(ppufile:tcompilerppufile);override;
  538. function GetTypeName:string;override;
  539. function getmangledparaname:string;override;
  540. function is_publishable : boolean;override;
  541. function alignment : shortint;override;
  542. { init/final }
  543. function needs_inittable : boolean;override;
  544. { rtti }
  545. procedure write_rtti_data(rt:trttitype);override;
  546. end;
  547. tenumdef = class(tstoreddef)
  548. minval,
  549. maxval : aint;
  550. has_jumps : boolean;
  551. firstenum : tsym; {tenumsym}
  552. basedef : tenumdef;
  553. basedefderef : tderef;
  554. constructor create;
  555. constructor create_subrange(_basedef:tenumdef;_min,_max:aint);
  556. constructor ppuload(ppufile:tcompilerppufile);
  557. destructor destroy;override;
  558. function getcopy : tstoreddef;override;
  559. procedure ppuwrite(ppufile:tcompilerppufile);override;
  560. procedure buildderef;override;
  561. procedure deref;override;
  562. procedure derefimpl;override;
  563. function GetTypeName:string;override;
  564. function is_publishable : boolean;override;
  565. procedure calcsavesize;
  566. function packedbitsize: aint; override;
  567. procedure setmax(_max:aint);
  568. procedure setmin(_min:aint);
  569. function min:aint;
  570. function max:aint;
  571. { rtti }
  572. procedure write_rtti_data(rt:trttitype);override;
  573. procedure write_child_rtti_data(rt:trttitype);override;
  574. end;
  575. tsetdef = class(tstoreddef)
  576. elementdef : tdef;
  577. elementdefderef : tderef;
  578. settype : tsettype;
  579. setbase,
  580. setmax : aint;
  581. constructor create(def:tdef;high : aint);
  582. constructor ppuload(ppufile:tcompilerppufile);
  583. destructor destroy;override;
  584. function getcopy : tstoreddef;override;
  585. procedure ppuwrite(ppufile:tcompilerppufile);override;
  586. procedure buildderef;override;
  587. procedure deref;override;
  588. function GetTypeName:string;override;
  589. function is_publishable : boolean;override;
  590. { rtti }
  591. procedure write_rtti_data(rt:trttitype);override;
  592. procedure write_child_rtti_data(rt:trttitype);override;
  593. end;
  594. Tdefmatch=(dm_exact,dm_equal,dm_convertl1);
  595. var
  596. aktobjectdef : tobjectdef; { used for private functions check !! }
  597. { default types }
  598. generrordef, { error in definition }
  599. voidpointertype, { pointer for Void-pointeddef }
  600. charpointertype, { pointer for Char-pointeddef }
  601. widecharpointertype, { pointer for WideChar-pointeddef }
  602. voidfarpointertype,
  603. cundefinedtype,
  604. cformaltype, { unique formal definition }
  605. voidtype, { Void (procedure) }
  606. cchartype, { Char }
  607. cwidechartype, { WideChar }
  608. booltype, { boolean type }
  609. bool16type,
  610. bool32type,
  611. bool64type, { implement me }
  612. u8inttype, { 8-Bit unsigned integer }
  613. s8inttype, { 8-Bit signed integer }
  614. u16inttype, { 16-Bit unsigned integer }
  615. s16inttype, { 16-Bit signed integer }
  616. u32inttype, { 32-Bit unsigned integer }
  617. s32inttype, { 32-Bit signed integer }
  618. u64inttype, { 64-bit unsigned integer }
  619. s64inttype, { 64-bit signed integer }
  620. s32floattype, { pointer for realconstn }
  621. s64floattype, { pointer for realconstn }
  622. s80floattype, { pointer to type of temp. floats }
  623. s64currencytype, { pointer to a currency type }
  624. cshortstringtype, { pointer to type of short string const }
  625. clongstringtype, { pointer to type of long string const }
  626. cansistringtype, { pointer to type of ansi string const }
  627. cwidestringtype, { pointer to type of wide string const }
  628. openshortstringtype, { pointer to type of an open shortstring,
  629. needed for readln() }
  630. openchararraytype, { pointer to type of an open array of char,
  631. needed for readln() }
  632. cfiletype, { get the same definition for all file }
  633. { used for stabs }
  634. methodpointertype, { typecasting of methodpointers to extract self }
  635. hresultdef,
  636. { we use only one variant def for every variant class }
  637. cvarianttype,
  638. colevarianttype,
  639. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  640. sinttype,
  641. uinttype,
  642. { unsigned ord type with the same size as a pointer }
  643. ptrinttype,
  644. { several types to simulate more or less C++ objects for GDB }
  645. vmttype,
  646. vmtarraytype,
  647. pvmttype : tdef; { type of classrefs, used for stabs }
  648. { pointer to the anchestor of all classes }
  649. class_tobject : tobjectdef;
  650. { pointer to the ancestor of all COM interfaces }
  651. interface_iunknown : tobjectdef;
  652. { pointer to the TGUID type
  653. of all interfaces }
  654. rec_tguid : trecorddef;
  655. const
  656. {$ifdef i386}
  657. pbestrealtype : ^tdef = @s80floattype;
  658. {$endif}
  659. {$ifdef x86_64}
  660. pbestrealtype : ^tdef = @s80floattype;
  661. {$endif}
  662. {$ifdef m68k}
  663. pbestrealtype : ^tdef = @s64floattype;
  664. {$endif}
  665. {$ifdef alpha}
  666. pbestrealtype : ^tdef = @s64floattype;
  667. {$endif}
  668. {$ifdef powerpc}
  669. pbestrealtype : ^tdef = @s64floattype;
  670. {$endif}
  671. {$ifdef POWERPC64}
  672. pbestrealtype : ^tdef = @s64floattype;
  673. {$endif}
  674. {$ifdef ia64}
  675. pbestrealtype : ^tdef = @s64floattype;
  676. {$endif}
  677. {$ifdef SPARC}
  678. pbestrealtype : ^tdef = @s64floattype;
  679. {$endif SPARC}
  680. {$ifdef vis}
  681. pbestrealtype : ^tdef = @s64floattype;
  682. {$endif vis}
  683. {$ifdef ARM}
  684. pbestrealtype : ^tdef = @s64floattype;
  685. {$endif ARM}
  686. {$ifdef MIPS}
  687. pbestrealtype : ^tdef = @s64floattype;
  688. {$endif MIPS}
  689. function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
  690. { should be in the types unit, but the types unit uses the node stuff :( }
  691. function is_interfacecom(def: tdef): boolean;
  692. function is_interfacecorba(def: tdef): boolean;
  693. function is_interface(def: tdef): boolean;
  694. function is_dispinterface(def: tdef): boolean;
  695. function is_object(def: tdef): boolean;
  696. function is_class(def: tdef): boolean;
  697. function is_cppclass(def: tdef): boolean;
  698. function is_class_or_interface(def: tdef): boolean;
  699. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  700. {$ifdef x86}
  701. function use_sse(def : tdef) : boolean;
  702. {$endif x86}
  703. implementation
  704. uses
  705. SysUtils,
  706. cutils,
  707. { global }
  708. verbose,
  709. { target }
  710. systems,aasmcpu,paramgr,
  711. { symtable }
  712. symsym,symtable,symutil,defutil,
  713. { module }
  714. fmodule,
  715. { other }
  716. gendef,
  717. fpccrc
  718. ;
  719. {****************************************************************************
  720. Constants
  721. ****************************************************************************}
  722. const
  723. varempty = 0;
  724. varnull = 1;
  725. varsmallint = 2;
  726. varinteger = 3;
  727. varsingle = 4;
  728. vardouble = 5;
  729. varcurrency = 6;
  730. vardate = 7;
  731. varolestr = 8;
  732. vardispatch = 9;
  733. varerror = 10;
  734. varboolean = 11;
  735. varvariant = 12;
  736. varunknown = 13;
  737. vardecimal = 14;
  738. varshortint = 16;
  739. varbyte = 17;
  740. varword = 18;
  741. varlongword = 19;
  742. varint64 = 20;
  743. varqword = 21;
  744. varUndefined = -1;
  745. varstrarg = $48;
  746. varstring = $100;
  747. varany = $101;
  748. vardefmask = $fff;
  749. vararray = $2000;
  750. varbyref = $4000;
  751. {****************************************************************************
  752. Helpers
  753. ****************************************************************************}
  754. function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
  755. var
  756. s,hs,
  757. prefix : string;
  758. oldlen,
  759. newlen,
  760. i : longint;
  761. crc : dword;
  762. hp : tparavarsym;
  763. begin
  764. prefix:='';
  765. if not assigned(st) then
  766. internalerror(200204212);
  767. { sub procedures }
  768. while (st.symtabletype=localsymtable) do
  769. begin
  770. if st.defowner.deftype<>procdef then
  771. internalerror(200204173);
  772. { Add the full mangledname of procedure to prevent
  773. conflicts with 2 overloads having both a nested procedure
  774. with the same name, see tb0314 (PFV) }
  775. s:=tprocdef(st.defowner).procsym.name;
  776. oldlen:=length(s);
  777. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  778. begin
  779. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  780. if not(vo_is_hidden_para in hp.varoptions) then
  781. s:=s+'$'+hp.vardef.mangledparaname;
  782. end;
  783. if not is_void(tprocdef(st.defowner).returndef) then
  784. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  785. newlen:=length(s);
  786. { Replace with CRC if the parameter line is very long }
  787. if (newlen-oldlen>12) and
  788. ((newlen>128) or (newlen-oldlen>64)) then
  789. begin
  790. crc:=$ffffffff;
  791. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  792. begin
  793. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  794. if not(vo_is_hidden_para in hp.varoptions) then
  795. begin
  796. hs:=hp.vardef.mangledparaname;
  797. crc:=UpdateCrc32(crc,hs[1],length(hs));
  798. end;
  799. end;
  800. hs:=hp.vardef.mangledparaname;
  801. crc:=UpdateCrc32(crc,hs[1],length(hs));
  802. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  803. end;
  804. if prefix<>'' then
  805. prefix:=s+'_'+prefix
  806. else
  807. prefix:=s;
  808. st:=st.defowner.owner;
  809. end;
  810. { object/classes symtable }
  811. if (st.symtabletype=objectsymtable) then
  812. begin
  813. if st.defowner.deftype<>objectdef then
  814. internalerror(200204174);
  815. prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
  816. st:=st.defowner.owner;
  817. end;
  818. { symtable must now be static or global }
  819. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  820. internalerror(200204175);
  821. result:='';
  822. if typeprefix<>'' then
  823. result:=result+typeprefix+'_';
  824. { Add P$ for program, which can have the same name as
  825. a unit }
  826. if (tsymtable(main_module.localsymtable)=st) and
  827. (not main_module.is_unit) then
  828. result:=result+'P$'+st.name^
  829. else
  830. result:=result+st.name^;
  831. if prefix<>'' then
  832. result:=result+'_'+prefix;
  833. if suffix<>'' then
  834. result:=result+'_'+suffix;
  835. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  836. if (target_info.system in [system_powerpc_darwin,system_i386_darwin]) and
  837. (result[1] = 'L') then
  838. result := '_' + result;
  839. end;
  840. {****************************************************************************
  841. TDEF (base class for definitions)
  842. ****************************************************************************}
  843. constructor tstoreddef.create(dt:tdeftype);
  844. var
  845. insertstack : psymtablestackitem;
  846. begin
  847. inherited create(dt);
  848. savesize := 0;
  849. {$ifdef EXTDEBUG}
  850. fileinfo := current_filepos;
  851. {$endif}
  852. fillchar(localrttilab,sizeof(localrttilab),0);
  853. generictokenbuf:=nil;
  854. genericdef:=nil;
  855. { Don't register forwarddefs, they are disposed at the
  856. end of an type block }
  857. if (dt=forwarddef) then
  858. exit;
  859. { Register in current_module }
  860. if assigned(current_module) then
  861. begin
  862. current_module.deflist.Add(self);
  863. DefId:=current_module.deflist.Count-1;
  864. end;
  865. { Register in symtable stack }
  866. if assigned(symtablestack) then
  867. begin
  868. insertstack:=symtablestack.stack;
  869. while assigned(insertstack) and
  870. (insertstack^.symtable.symtabletype=withsymtable) do
  871. insertstack:=insertstack^.next;
  872. if not assigned(insertstack) then
  873. internalerror(200602044);
  874. insertstack^.symtable.insertdef(self);
  875. end;
  876. end;
  877. destructor tstoreddef.destroy;
  878. begin
  879. { remove also index from symtable }
  880. if assigned(owner) then
  881. owner.deletedef(self);
  882. if assigned(generictokenbuf) then
  883. generictokenbuf.free;
  884. inherited destroy;
  885. end;
  886. constructor tstoreddef.ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  887. var
  888. sizeleft,i : longint;
  889. buf : array[0..255] of byte;
  890. begin
  891. inherited create(dt);
  892. {$ifdef EXTDEBUG}
  893. fillchar(fileinfo,sizeof(fileinfo),0);
  894. {$endif}
  895. fillchar(localrttilab,sizeof(localrttilab),0);
  896. { load }
  897. DefId:=ppufile.getlongint;
  898. current_module.deflist[DefId]:=self;
  899. indexnr:=ppufile.getword;
  900. ppufile.getderef(typesymderef);
  901. ppufile.getsmallset(defoptions);
  902. if df_has_rttitable in defoptions then
  903. ppufile.getderef(rttitablesymderef);
  904. if df_has_inittable in defoptions then
  905. ppufile.getderef(inittablesymderef);
  906. if df_generic in defoptions then
  907. begin
  908. sizeleft:=ppufile.getlongint;
  909. initgeneric;
  910. while sizeleft>0 do
  911. begin
  912. if sizeleft>sizeof(buf) then
  913. i:=sizeof(buf)
  914. else
  915. i:=sizeleft;
  916. ppufile.getdata(buf,i);
  917. generictokenbuf.write(buf,i);
  918. dec(sizeleft,i);
  919. end;
  920. end;
  921. if df_specialization in defoptions then
  922. ppufile.getderef(genericdefderef);
  923. end;
  924. procedure Tstoreddef.reset;
  925. begin
  926. if assigned(rttitablesym) then
  927. trttisym(rttitablesym).lab := nil;
  928. if assigned(inittablesym) then
  929. trttisym(inittablesym).lab := nil;
  930. localrttilab[initrtti]:=nil;
  931. localrttilab[fullrtti]:=nil;
  932. end;
  933. function tstoreddef.getcopy : tstoreddef;
  934. begin
  935. Message(sym_e_cant_create_unique_type);
  936. getcopy:=terrordef.create;
  937. end;
  938. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  939. var
  940. sizeleft,i : longint;
  941. buf : array[0..255] of byte;
  942. oldintfcrc : boolean;
  943. begin
  944. ppufile.putlongint(DefId);
  945. ppufile.putword(indexnr);
  946. ppufile.putderef(typesymderef);
  947. ppufile.putsmallset(defoptions);
  948. if df_has_rttitable in defoptions then
  949. ppufile.putderef(rttitablesymderef);
  950. if df_has_inittable in defoptions then
  951. ppufile.putderef(inittablesymderef);
  952. if df_generic in defoptions then
  953. begin
  954. oldintfcrc:=ppufile.do_interface_crc;
  955. ppufile.do_interface_crc:=false;
  956. if assigned(generictokenbuf) then
  957. begin
  958. sizeleft:=generictokenbuf.size;
  959. generictokenbuf.seek(0);
  960. end
  961. else
  962. sizeleft:=0;
  963. ppufile.putlongint(sizeleft);
  964. while sizeleft>0 do
  965. begin
  966. if sizeleft>sizeof(buf) then
  967. i:=sizeof(buf)
  968. else
  969. i:=sizeleft;
  970. generictokenbuf.read(buf,i);
  971. ppufile.putdata(buf,i);
  972. dec(sizeleft,i);
  973. end;
  974. ppufile.do_interface_crc:=oldintfcrc;
  975. end;
  976. if df_specialization in defoptions then
  977. ppufile.putderef(genericdefderef);
  978. end;
  979. procedure tstoreddef.buildderef;
  980. begin
  981. typesymderef.build(typesym);
  982. rttitablesymderef.build(rttitablesym);
  983. inittablesymderef.build(inittablesym);
  984. genericdefderef.build(genericdef);
  985. end;
  986. procedure tstoreddef.buildderefimpl;
  987. begin
  988. end;
  989. procedure tstoreddef.deref;
  990. begin
  991. typesym:=ttypesym(typesymderef.resolve);
  992. if df_has_rttitable in defoptions then
  993. rttitablesym:=trttisym(rttitablesymderef.resolve);
  994. if df_has_inittable in defoptions then
  995. inittablesym:=trttisym(inittablesymderef.resolve);
  996. if df_specialization in defoptions then
  997. genericdef:=tstoreddef(genericdefderef.resolve);
  998. end;
  999. procedure tstoreddef.derefimpl;
  1000. begin
  1001. end;
  1002. function tstoreddef.size : aint;
  1003. begin
  1004. size:=savesize;
  1005. end;
  1006. function tstoreddef.getvardef:longint;
  1007. begin
  1008. result:=varUndefined;
  1009. end;
  1010. function tstoreddef.alignment : shortint;
  1011. begin
  1012. { natural alignment by default }
  1013. alignment:=size_2_align(savesize);
  1014. end;
  1015. procedure tstoreddef.write_rtti_name;
  1016. var
  1017. str : string;
  1018. begin
  1019. { name }
  1020. if assigned(typesym) then
  1021. begin
  1022. str:=ttypesym(typesym).realname;
  1023. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(chr(length(str))+str));
  1024. end
  1025. else
  1026. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(#0))
  1027. end;
  1028. procedure tstoreddef.write_rtti_data(rt:trttitype);
  1029. begin
  1030. current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
  1031. write_rtti_name;
  1032. end;
  1033. procedure tstoreddef.write_child_rtti_data(rt:trttitype);
  1034. begin
  1035. end;
  1036. function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
  1037. begin
  1038. { try to reuse persistent rtti data }
  1039. if (rt=fullrtti) and (df_has_rttitable in defoptions) then
  1040. get_rtti_label:=trttisym(rttitablesym).get_label
  1041. else
  1042. if (rt=initrtti) and (df_has_inittable in defoptions) then
  1043. get_rtti_label:=trttisym(inittablesym).get_label
  1044. else
  1045. begin
  1046. if not assigned(localrttilab[rt]) then
  1047. begin
  1048. current_asmdata.getdatalabel(localrttilab[rt]);
  1049. write_child_rtti_data(rt);
  1050. maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
  1051. new_section(current_asmdata.asmlists[al_rtti],sec_rodata,localrttilab[rt].name,const_align(sizeof(aint)));
  1052. current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(localrttilab[rt],0));
  1053. write_rtti_data(rt);
  1054. current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(localrttilab[rt]));
  1055. end;
  1056. get_rtti_label:=localrttilab[rt];
  1057. end;
  1058. end;
  1059. { returns true, if the definition can be published }
  1060. function tstoreddef.is_publishable : boolean;
  1061. begin
  1062. is_publishable:=false;
  1063. end;
  1064. { needs an init table }
  1065. function tstoreddef.needs_inittable : boolean;
  1066. begin
  1067. needs_inittable:=false;
  1068. end;
  1069. function tstoreddef.is_intregable : boolean;
  1070. var
  1071. recsize,temp: longint;
  1072. begin
  1073. is_intregable:=false;
  1074. case deftype of
  1075. orddef,
  1076. pointerdef,
  1077. enumdef,
  1078. classrefdef:
  1079. is_intregable:=true;
  1080. procvardef :
  1081. is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
  1082. objectdef:
  1083. is_intregable:=is_class(self) or is_interface(self);
  1084. setdef:
  1085. is_intregable:=(tsetdef(self).settype=smallset);
  1086. recorddef:
  1087. begin
  1088. recsize:=size;
  1089. is_intregable:=
  1090. ispowerof2(recsize,temp) and
  1091. (recsize <= sizeof(aint));
  1092. end;
  1093. end;
  1094. end;
  1095. function tstoreddef.is_fpuregable : boolean;
  1096. begin
  1097. {$ifdef x86}
  1098. result:=use_sse(self);
  1099. {$else x86}
  1100. result:=(deftype=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  1101. {$endif x86}
  1102. end;
  1103. procedure tstoreddef.initgeneric;
  1104. begin
  1105. if assigned(generictokenbuf) then
  1106. internalerror(200512131);
  1107. generictokenbuf:=tdynamicarray.create(256);
  1108. end;
  1109. {****************************************************************************
  1110. Tstringdef
  1111. ****************************************************************************}
  1112. constructor tstringdef.createshort(l : byte);
  1113. begin
  1114. inherited create(stringdef);
  1115. string_typ:=st_shortstring;
  1116. len:=l;
  1117. savesize:=len+1;
  1118. end;
  1119. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1120. begin
  1121. inherited ppuload(stringdef,ppufile);
  1122. string_typ:=st_shortstring;
  1123. len:=ppufile.getbyte;
  1124. savesize:=len+1;
  1125. end;
  1126. constructor tstringdef.createlong(l : aint);
  1127. begin
  1128. inherited create(stringdef);
  1129. string_typ:=st_longstring;
  1130. len:=l;
  1131. savesize:=sizeof(aint);
  1132. end;
  1133. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1134. begin
  1135. inherited ppuload(stringdef,ppufile);
  1136. string_typ:=st_longstring;
  1137. len:=ppufile.getaint;
  1138. savesize:=sizeof(aint);
  1139. end;
  1140. constructor tstringdef.createansi(l:aint);
  1141. begin
  1142. inherited create(stringdef);
  1143. string_typ:=st_ansistring;
  1144. len:=l;
  1145. savesize:=sizeof(aint);
  1146. end;
  1147. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1148. begin
  1149. inherited ppuload(stringdef,ppufile);
  1150. string_typ:=st_ansistring;
  1151. len:=ppufile.getaint;
  1152. savesize:=sizeof(aint);
  1153. end;
  1154. constructor tstringdef.createwide(l : aint);
  1155. begin
  1156. inherited create(stringdef);
  1157. string_typ:=st_widestring;
  1158. len:=l;
  1159. savesize:=sizeof(aint);
  1160. end;
  1161. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1162. begin
  1163. inherited ppuload(stringdef,ppufile);
  1164. string_typ:=st_widestring;
  1165. len:=ppufile.getaint;
  1166. savesize:=sizeof(aint);
  1167. end;
  1168. function tstringdef.getcopy : tstoreddef;
  1169. begin
  1170. result:=tstringdef.create(deftype);
  1171. result.deftype:=stringdef;
  1172. tstringdef(result).string_typ:=string_typ;
  1173. tstringdef(result).len:=len;
  1174. tstringdef(result).savesize:=savesize;
  1175. end;
  1176. function tstringdef.stringtypname:string;
  1177. const
  1178. typname:array[tstringtype] of string[8]=(
  1179. 'shortstr','longstr','ansistr','widestr'
  1180. );
  1181. begin
  1182. stringtypname:=typname[string_typ];
  1183. end;
  1184. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1185. begin
  1186. inherited ppuwrite(ppufile);
  1187. if string_typ=st_shortstring then
  1188. begin
  1189. {$ifdef extdebug}
  1190. if len > 255 then internalerror(12122002);
  1191. {$endif}
  1192. ppufile.putbyte(byte(len))
  1193. end
  1194. else
  1195. ppufile.putaint(len);
  1196. case string_typ of
  1197. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1198. st_longstring : ppufile.writeentry(iblongstringdef);
  1199. st_ansistring : ppufile.writeentry(ibansistringdef);
  1200. st_widestring : ppufile.writeentry(ibwidestringdef);
  1201. end;
  1202. end;
  1203. function tstringdef.needs_inittable : boolean;
  1204. begin
  1205. needs_inittable:=string_typ in [st_ansistring,st_widestring];
  1206. end;
  1207. function tstringdef.GetTypeName : string;
  1208. const
  1209. names : array[tstringtype] of string[11] = (
  1210. 'ShortString','LongString','AnsiString','WideString');
  1211. begin
  1212. GetTypeName:=names[string_typ];
  1213. end;
  1214. function tstringdef.alignment : shortint;
  1215. begin
  1216. case string_typ of
  1217. st_widestring,
  1218. st_ansistring:
  1219. alignment:=size_2_align(savesize);
  1220. st_longstring,
  1221. st_shortstring:
  1222. {$ifdef cpurequiresproperalignment}
  1223. { char to string accesses byte 0 and 1 with one word access }
  1224. alignment:=size_2_align(2);
  1225. {$else cpurequiresproperalignment}
  1226. alignment:=size_2_align(1);
  1227. {$endif cpurequiresproperalignment}
  1228. else
  1229. internalerror(200412301);
  1230. end;
  1231. end;
  1232. procedure tstringdef.write_rtti_data(rt:trttitype);
  1233. begin
  1234. case string_typ of
  1235. st_ansistring:
  1236. begin
  1237. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkAString));
  1238. write_rtti_name;
  1239. end;
  1240. st_widestring:
  1241. begin
  1242. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWString));
  1243. write_rtti_name;
  1244. end;
  1245. st_longstring:
  1246. begin
  1247. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkLString));
  1248. write_rtti_name;
  1249. end;
  1250. st_shortstring:
  1251. begin
  1252. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSString));
  1253. write_rtti_name;
  1254. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(len));
  1255. {$ifdef cpurequiresproperalignment}
  1256. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1257. {$endif cpurequiresproperalignment}
  1258. end;
  1259. end;
  1260. end;
  1261. function tstringdef.getmangledparaname : string;
  1262. begin
  1263. getmangledparaname:='STRING';
  1264. end;
  1265. function tstringdef.is_publishable : boolean;
  1266. begin
  1267. is_publishable:=true;
  1268. end;
  1269. {****************************************************************************
  1270. TENUMDEF
  1271. ****************************************************************************}
  1272. constructor tenumdef.create;
  1273. begin
  1274. inherited create(enumdef);
  1275. minval:=0;
  1276. maxval:=0;
  1277. calcsavesize;
  1278. has_jumps:=false;
  1279. basedef:=nil;
  1280. firstenum:=nil;
  1281. end;
  1282. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:aint);
  1283. begin
  1284. inherited create(enumdef);
  1285. minval:=_min;
  1286. maxval:=_max;
  1287. basedef:=_basedef;
  1288. calcsavesize;
  1289. has_jumps:=false;
  1290. firstenum:=basedef.firstenum;
  1291. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1292. firstenum:=tenumsym(firstenum).nextenum;
  1293. end;
  1294. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1295. begin
  1296. inherited ppuload(enumdef,ppufile);
  1297. ppufile.getderef(basedefderef);
  1298. minval:=ppufile.getaint;
  1299. maxval:=ppufile.getaint;
  1300. savesize:=ppufile.getaint;
  1301. has_jumps:=false;
  1302. firstenum:=Nil;
  1303. end;
  1304. function tenumdef.getcopy : tstoreddef;
  1305. begin
  1306. if assigned(basedef) then
  1307. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1308. else
  1309. begin
  1310. result:=tenumdef.create;
  1311. tenumdef(result).minval:=minval;
  1312. tenumdef(result).maxval:=maxval;
  1313. end;
  1314. tenumdef(result).has_jumps:=has_jumps;
  1315. tenumdef(result).firstenum:=firstenum;
  1316. tenumdef(result).basedefderef:=basedefderef;
  1317. end;
  1318. procedure tenumdef.calcsavesize;
  1319. begin
  1320. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1321. savesize:=8
  1322. else
  1323. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1324. savesize:=4
  1325. else
  1326. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1327. savesize:=2
  1328. else
  1329. savesize:=1;
  1330. end;
  1331. function tenumdef.packedbitsize: aint;
  1332. var
  1333. power: longint;
  1334. begin
  1335. result := 0;
  1336. if (minval < 0) then
  1337. result := inherited packedbitsize
  1338. else
  1339. begin
  1340. if (maxval <= 1) then
  1341. result := 1
  1342. else
  1343. begin
  1344. { 256 must become 512 etc. }
  1345. nextpowerof2(maxval+1,power);
  1346. result := power;
  1347. end;
  1348. end;
  1349. end;
  1350. procedure tenumdef.setmax(_max:aint);
  1351. begin
  1352. maxval:=_max;
  1353. calcsavesize;
  1354. end;
  1355. procedure tenumdef.setmin(_min:aint);
  1356. begin
  1357. minval:=_min;
  1358. calcsavesize;
  1359. end;
  1360. function tenumdef.min:aint;
  1361. begin
  1362. min:=minval;
  1363. end;
  1364. function tenumdef.max:aint;
  1365. begin
  1366. max:=maxval;
  1367. end;
  1368. procedure tenumdef.buildderef;
  1369. begin
  1370. inherited buildderef;
  1371. basedefderef.build(basedef);
  1372. end;
  1373. procedure tenumdef.deref;
  1374. begin
  1375. inherited deref;
  1376. basedef:=tenumdef(basedefderef.resolve);
  1377. { restart ordering }
  1378. firstenum:=nil;
  1379. end;
  1380. procedure tenumdef.derefimpl;
  1381. begin
  1382. if assigned(basedef) and
  1383. (firstenum=nil) then
  1384. begin
  1385. firstenum:=basedef.firstenum;
  1386. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1387. firstenum:=tenumsym(firstenum).nextenum;
  1388. end;
  1389. end;
  1390. destructor tenumdef.destroy;
  1391. begin
  1392. inherited destroy;
  1393. end;
  1394. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1395. begin
  1396. inherited ppuwrite(ppufile);
  1397. ppufile.putderef(basedefderef);
  1398. ppufile.putaint(min);
  1399. ppufile.putaint(max);
  1400. ppufile.putaint(savesize);
  1401. ppufile.writeentry(ibenumdef);
  1402. end;
  1403. procedure tenumdef.write_child_rtti_data(rt:trttitype);
  1404. begin
  1405. if assigned(basedef) then
  1406. basedef.get_rtti_label(rt);
  1407. end;
  1408. procedure tenumdef.write_rtti_data(rt:trttitype);
  1409. var
  1410. hp : tenumsym;
  1411. begin
  1412. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkEnumeration));
  1413. write_rtti_name;
  1414. {$ifdef cpurequiresproperalignment}
  1415. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1416. {$endif cpurequiresproperalignment}
  1417. case longint(savesize) of
  1418. 1:
  1419. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otUByte));
  1420. 2:
  1421. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otUWord));
  1422. 4:
  1423. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otULong));
  1424. end;
  1425. {$ifdef cpurequiresproperalignment}
  1426. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1427. {$endif cpurequiresproperalignment}
  1428. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(min));
  1429. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(max));
  1430. if assigned(basedef) then
  1431. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(basedef.get_rtti_label(rt)))
  1432. else
  1433. current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
  1434. hp:=tenumsym(firstenum);
  1435. while assigned(hp) do
  1436. begin
  1437. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(hp.realname)));
  1438. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(hp.realname));
  1439. hp:=hp.nextenum;
  1440. end;
  1441. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
  1442. end;
  1443. function tenumdef.is_publishable : boolean;
  1444. begin
  1445. is_publishable:=true;
  1446. end;
  1447. function tenumdef.GetTypeName : string;
  1448. begin
  1449. GetTypeName:='<enumeration type>';
  1450. end;
  1451. {****************************************************************************
  1452. TORDDEF
  1453. ****************************************************************************}
  1454. constructor torddef.create(t : tbasetype;v,b : TConstExprInt);
  1455. begin
  1456. inherited create(orddef);
  1457. low:=v;
  1458. high:=b;
  1459. typ:=t;
  1460. setsize;
  1461. end;
  1462. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1463. begin
  1464. inherited ppuload(orddef,ppufile);
  1465. typ:=tbasetype(ppufile.getbyte);
  1466. if sizeof(TConstExprInt)=8 then
  1467. begin
  1468. low:=ppufile.getint64;
  1469. high:=ppufile.getint64;
  1470. end
  1471. else
  1472. begin
  1473. low:=ppufile.getlongint;
  1474. high:=ppufile.getlongint;
  1475. end;
  1476. setsize;
  1477. end;
  1478. function torddef.getcopy : tstoreddef;
  1479. begin
  1480. result:=torddef.create(typ,low,high);
  1481. result.deftype:=orddef;
  1482. torddef(result).low:=low;
  1483. torddef(result).high:=high;
  1484. torddef(result).typ:=typ;
  1485. torddef(result).savesize:=savesize;
  1486. end;
  1487. function torddef.alignment:shortint;
  1488. begin
  1489. if (target_info.system = system_i386_darwin) and
  1490. (typ in [s64bit,u64bit]) then
  1491. result := 4
  1492. else
  1493. result := inherited alignment;
  1494. end;
  1495. procedure torddef.setsize;
  1496. const
  1497. sizetbl : array[tbasetype] of longint = (
  1498. 0,
  1499. 1,2,4,8,
  1500. 1,2,4,8,
  1501. 1,2,4,8,
  1502. 1,2,8
  1503. );
  1504. begin
  1505. savesize:=sizetbl[typ];
  1506. end;
  1507. function torddef.packedbitsize: aint;
  1508. var
  1509. power: longint;
  1510. begin
  1511. result := 0;
  1512. if typ = uvoid then
  1513. exit;
  1514. if (low < 0) then
  1515. result := inherited packedbitsize
  1516. else
  1517. begin
  1518. if (high <= 1) then
  1519. result := 1
  1520. else if (typ = u64bit) then
  1521. result := 64
  1522. else
  1523. begin
  1524. { 256 must become 512 etc. }
  1525. nextpowerof2(high+1,power);
  1526. result := power;
  1527. end;
  1528. end;
  1529. end;
  1530. function torddef.getvardef : longint;
  1531. const
  1532. basetype2vardef : array[tbasetype] of longint = (
  1533. varUndefined,
  1534. varbyte,varqword,varlongword,varqword,
  1535. varshortint,varsmallint,varinteger,varint64,
  1536. varboolean,varUndefined,varUndefined,varUndefined,
  1537. varUndefined,varUndefined,varCurrency);
  1538. begin
  1539. result:=basetype2vardef[typ];
  1540. end;
  1541. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1542. begin
  1543. inherited ppuwrite(ppufile);
  1544. ppufile.putbyte(byte(typ));
  1545. if sizeof(TConstExprInt)=8 then
  1546. begin
  1547. ppufile.putint64(low);
  1548. ppufile.putint64(high);
  1549. end
  1550. else
  1551. begin
  1552. ppufile.putlongint(low);
  1553. ppufile.putlongint(high);
  1554. end;
  1555. ppufile.writeentry(iborddef);
  1556. end;
  1557. procedure torddef.write_rtti_data(rt:trttitype);
  1558. procedure dointeger;
  1559. const
  1560. trans : array[tbasetype] of byte =
  1561. (otUByte{otNone},
  1562. otUByte,otUWord,otULong,otUByte{otNone},
  1563. otSByte,otSWord,otSLong,otUByte{otNone},
  1564. otUByte,otUWord,otULong,otUByte,
  1565. otUByte,otUWord,otUByte);
  1566. begin
  1567. write_rtti_name;
  1568. {$ifdef cpurequiresproperalignment}
  1569. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1570. {$endif cpurequiresproperalignment}
  1571. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(byte(trans[typ])));
  1572. {$ifdef cpurequiresproperalignment}
  1573. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1574. {$endif cpurequiresproperalignment}
  1575. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(low)));
  1576. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(high)));
  1577. end;
  1578. begin
  1579. case typ of
  1580. s64bit :
  1581. begin
  1582. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkInt64));
  1583. write_rtti_name;
  1584. {$ifdef cpurequiresproperalignment}
  1585. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1586. {$endif cpurequiresproperalignment}
  1587. { low }
  1588. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(int64($80000000) shl 32));
  1589. { high }
  1590. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit((int64($7fffffff) shl 32) or int64($ffffffff)));
  1591. end;
  1592. u64bit :
  1593. begin
  1594. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkQWord));
  1595. write_rtti_name;
  1596. {$ifdef cpurequiresproperalignment}
  1597. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1598. {$endif cpurequiresproperalignment}
  1599. { low }
  1600. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(0));
  1601. { high }
  1602. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(int64((int64($ffffffff) shl 32) or int64($ffffffff))));
  1603. end;
  1604. bool8bit:
  1605. begin
  1606. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkBool));
  1607. dointeger;
  1608. end;
  1609. uchar:
  1610. begin
  1611. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkChar));
  1612. dointeger;
  1613. end;
  1614. uwidechar:
  1615. begin
  1616. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWChar));
  1617. dointeger;
  1618. end;
  1619. else
  1620. begin
  1621. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkInteger));
  1622. dointeger;
  1623. end;
  1624. end;
  1625. end;
  1626. function torddef.is_publishable : boolean;
  1627. begin
  1628. is_publishable:=(typ<>uvoid);
  1629. end;
  1630. function torddef.GetTypeName : string;
  1631. const
  1632. names : array[tbasetype] of string[20] = (
  1633. 'untyped',
  1634. 'Byte','Word','DWord','QWord',
  1635. 'ShortInt','SmallInt','LongInt','Int64',
  1636. 'Boolean','WordBool','LongBool','QWordBool',
  1637. 'Char','WideChar','Currency');
  1638. begin
  1639. GetTypeName:=names[typ];
  1640. end;
  1641. {****************************************************************************
  1642. TFLOATDEF
  1643. ****************************************************************************}
  1644. constructor tfloatdef.create(t : tfloattype);
  1645. begin
  1646. inherited create(floatdef);
  1647. typ:=t;
  1648. setsize;
  1649. end;
  1650. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1651. begin
  1652. inherited ppuload(floatdef,ppufile);
  1653. typ:=tfloattype(ppufile.getbyte);
  1654. setsize;
  1655. end;
  1656. function tfloatdef.getcopy : tstoreddef;
  1657. begin
  1658. result:=tfloatdef.create(typ);
  1659. result.deftype:=floatdef;
  1660. tfloatdef(result).savesize:=savesize;
  1661. end;
  1662. function tfloatdef.alignment:shortint;
  1663. begin
  1664. if (target_info.system = system_i386_darwin) then
  1665. case typ of
  1666. s80real : result:=16;
  1667. s64real,
  1668. s64currency,
  1669. s64comp : result:=4;
  1670. else
  1671. result := inherited alignment;
  1672. end
  1673. else
  1674. result := inherited alignment;
  1675. end;
  1676. procedure tfloatdef.setsize;
  1677. begin
  1678. case typ of
  1679. s32real : savesize:=4;
  1680. s80real : savesize:=10;
  1681. s64real,
  1682. s64currency,
  1683. s64comp : savesize:=8;
  1684. else
  1685. savesize:=0;
  1686. end;
  1687. end;
  1688. function tfloatdef.getvardef : longint;
  1689. const
  1690. floattype2vardef : array[tfloattype] of longint = (
  1691. varSingle,varDouble,varUndefined,
  1692. varUndefined,varCurrency,varUndefined);
  1693. begin
  1694. if (upper(typename)='TDATETIME') and
  1695. assigned(owner) and
  1696. assigned(owner.name) and
  1697. (owner.name^='SYSTEM') then
  1698. result:=varDate
  1699. else
  1700. result:=floattype2vardef[typ];
  1701. end;
  1702. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1703. begin
  1704. inherited ppuwrite(ppufile);
  1705. ppufile.putbyte(byte(typ));
  1706. ppufile.writeentry(ibfloatdef);
  1707. end;
  1708. procedure tfloatdef.write_rtti_data(rt:trttitype);
  1709. const
  1710. {tfloattype = (s32real,s64real,s80real,s64bit,s128bit);}
  1711. translate : array[tfloattype] of byte =
  1712. (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,ftFloat128);
  1713. begin
  1714. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkFloat));
  1715. write_rtti_name;
  1716. {$ifdef cpurequiresproperalignment}
  1717. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  1718. {$endif cpurequiresproperalignment}
  1719. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(translate[typ]));
  1720. end;
  1721. function tfloatdef.is_publishable : boolean;
  1722. begin
  1723. is_publishable:=true;
  1724. end;
  1725. function tfloatdef.GetTypeName : string;
  1726. const
  1727. names : array[tfloattype] of string[20] = (
  1728. 'Single','Double','Extended','Comp','Currency','Float128');
  1729. begin
  1730. GetTypeName:=names[typ];
  1731. end;
  1732. {****************************************************************************
  1733. TFILEDEF
  1734. ****************************************************************************}
  1735. constructor tfiledef.createtext;
  1736. begin
  1737. inherited create(filedef);
  1738. filetyp:=ft_text;
  1739. typedfiledef:=nil;
  1740. setsize;
  1741. end;
  1742. constructor tfiledef.createuntyped;
  1743. begin
  1744. inherited create(filedef);
  1745. filetyp:=ft_untyped;
  1746. typedfiledef:=nil;
  1747. setsize;
  1748. end;
  1749. constructor tfiledef.createtyped(def:tdef);
  1750. begin
  1751. inherited create(filedef);
  1752. filetyp:=ft_typed;
  1753. typedfiledef:=def;
  1754. setsize;
  1755. end;
  1756. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1757. begin
  1758. inherited ppuload(filedef,ppufile);
  1759. filetyp:=tfiletyp(ppufile.getbyte);
  1760. if filetyp=ft_typed then
  1761. ppufile.getderef(typedfiledefderef)
  1762. else
  1763. typedfiledef:=nil;
  1764. setsize;
  1765. end;
  1766. function tfiledef.getcopy : tstoreddef;
  1767. begin
  1768. case filetyp of
  1769. ft_typed:
  1770. result:=tfiledef.createtyped(typedfiledef);
  1771. ft_untyped:
  1772. result:=tfiledef.createuntyped;
  1773. ft_text:
  1774. result:=tfiledef.createtext;
  1775. else
  1776. internalerror(2004121201);
  1777. end;
  1778. end;
  1779. procedure tfiledef.buildderef;
  1780. begin
  1781. inherited buildderef;
  1782. if filetyp=ft_typed then
  1783. typedfiledefderef.build(typedfiledef);
  1784. end;
  1785. procedure tfiledef.deref;
  1786. begin
  1787. inherited deref;
  1788. if filetyp=ft_typed then
  1789. typedfiledef:=tdef(typedfiledefderef.resolve);
  1790. end;
  1791. procedure tfiledef.setsize;
  1792. begin
  1793. {$ifdef cpu64bit}
  1794. case filetyp of
  1795. ft_text :
  1796. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1797. savesize:=632
  1798. else
  1799. savesize:=628;
  1800. ft_typed,
  1801. ft_untyped :
  1802. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1803. savesize:=372
  1804. else
  1805. savesize:=368;
  1806. end;
  1807. {$else cpu64bit}
  1808. case filetyp of
  1809. ft_text :
  1810. savesize:=592;
  1811. ft_typed,
  1812. ft_untyped :
  1813. savesize:=332;
  1814. end;
  1815. {$endif cpu64bit}
  1816. end;
  1817. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  1818. begin
  1819. inherited ppuwrite(ppufile);
  1820. ppufile.putbyte(byte(filetyp));
  1821. if filetyp=ft_typed then
  1822. ppufile.putderef(typedfiledefderef);
  1823. ppufile.writeentry(ibfiledef);
  1824. end;
  1825. function tfiledef.GetTypeName : string;
  1826. begin
  1827. case filetyp of
  1828. ft_untyped:
  1829. GetTypeName:='File';
  1830. ft_typed:
  1831. GetTypeName:='File Of '+typedfiledef.typename;
  1832. ft_text:
  1833. GetTypeName:='Text'
  1834. end;
  1835. end;
  1836. function tfiledef.getmangledparaname : string;
  1837. begin
  1838. case filetyp of
  1839. ft_untyped:
  1840. getmangledparaname:='FILE';
  1841. ft_typed:
  1842. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  1843. ft_text:
  1844. getmangledparaname:='TEXT'
  1845. end;
  1846. end;
  1847. {****************************************************************************
  1848. TVARIANTDEF
  1849. ****************************************************************************}
  1850. constructor tvariantdef.create(v : tvarianttype);
  1851. begin
  1852. inherited create(variantdef);
  1853. varianttype:=v;
  1854. setsize;
  1855. end;
  1856. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  1857. begin
  1858. inherited ppuload(variantdef,ppufile);
  1859. varianttype:=tvarianttype(ppufile.getbyte);
  1860. setsize;
  1861. end;
  1862. function tvariantdef.getcopy : tstoreddef;
  1863. begin
  1864. result:=tvariantdef.create(varianttype);
  1865. end;
  1866. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  1867. begin
  1868. inherited ppuwrite(ppufile);
  1869. ppufile.putbyte(byte(varianttype));
  1870. ppufile.writeentry(ibvariantdef);
  1871. end;
  1872. procedure tvariantdef.setsize;
  1873. begin
  1874. {$ifdef cpu64bit}
  1875. savesize:=24;
  1876. {$else cpu64bit}
  1877. savesize:=16;
  1878. {$endif cpu64bit}
  1879. end;
  1880. function tvariantdef.GetTypeName : string;
  1881. begin
  1882. case varianttype of
  1883. vt_normalvariant:
  1884. GetTypeName:='Variant';
  1885. vt_olevariant:
  1886. GetTypeName:='OleVariant';
  1887. end;
  1888. end;
  1889. procedure tvariantdef.write_rtti_data(rt:trttitype);
  1890. begin
  1891. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkVariant));
  1892. end;
  1893. function tvariantdef.needs_inittable : boolean;
  1894. begin
  1895. needs_inittable:=true;
  1896. end;
  1897. function tvariantdef.is_publishable : boolean;
  1898. begin
  1899. is_publishable:=true;
  1900. end;
  1901. {****************************************************************************
  1902. TABSTRACtpointerdef
  1903. ****************************************************************************}
  1904. constructor tabstractpointerdef.create(dt:tdeftype;def:tdef);
  1905. begin
  1906. inherited create(dt);
  1907. pointeddef:=def;
  1908. savesize:=sizeof(aint);
  1909. end;
  1910. constructor tabstractpointerdef.ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  1911. begin
  1912. inherited ppuload(dt,ppufile);
  1913. ppufile.getderef(pointeddefderef);
  1914. savesize:=sizeof(aint);
  1915. end;
  1916. procedure tabstractpointerdef.buildderef;
  1917. begin
  1918. inherited buildderef;
  1919. pointeddefderef.build(pointeddef);
  1920. end;
  1921. procedure tabstractpointerdef.deref;
  1922. begin
  1923. inherited deref;
  1924. pointeddef:=tdef(pointeddefderef.resolve);
  1925. end;
  1926. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  1927. begin
  1928. inherited ppuwrite(ppufile);
  1929. ppufile.putderef(pointeddefderef);
  1930. end;
  1931. {****************************************************************************
  1932. tpointerdef
  1933. ****************************************************************************}
  1934. constructor tpointerdef.create(def:tdef);
  1935. begin
  1936. inherited create(pointerdef,def);
  1937. is_far:=false;
  1938. end;
  1939. constructor tpointerdef.createfar(def:tdef);
  1940. begin
  1941. inherited create(pointerdef,def);
  1942. is_far:=true;
  1943. end;
  1944. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  1945. begin
  1946. inherited ppuload(pointerdef,ppufile);
  1947. is_far:=(ppufile.getbyte<>0);
  1948. end;
  1949. function tpointerdef.getcopy : tstoreddef;
  1950. begin
  1951. result:=tpointerdef.create(pointeddef);
  1952. tpointerdef(result).is_far:=is_far;
  1953. tpointerdef(result).savesize:=savesize;
  1954. end;
  1955. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  1956. begin
  1957. inherited ppuwrite(ppufile);
  1958. ppufile.putbyte(byte(is_far));
  1959. ppufile.writeentry(ibpointerdef);
  1960. end;
  1961. function tpointerdef.GetTypeName : string;
  1962. begin
  1963. if is_far then
  1964. GetTypeName:='^'+pointeddef.typename+';far'
  1965. else
  1966. GetTypeName:='^'+pointeddef.typename;
  1967. end;
  1968. {****************************************************************************
  1969. TCLASSREFDEF
  1970. ****************************************************************************}
  1971. constructor tclassrefdef.create(def:tdef);
  1972. begin
  1973. inherited create(classrefdef,def);
  1974. end;
  1975. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  1976. begin
  1977. inherited ppuload(classrefdef,ppufile);
  1978. end;
  1979. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  1980. begin
  1981. inherited ppuwrite(ppufile);
  1982. ppufile.writeentry(ibclassrefdef);
  1983. end;
  1984. function tclassrefdef.GetTypeName : string;
  1985. begin
  1986. GetTypeName:='Class Of '+pointeddef.typename;
  1987. end;
  1988. function tclassrefdef.is_publishable : boolean;
  1989. begin
  1990. result:=true;
  1991. end;
  1992. {***************************************************************************
  1993. TSETDEF
  1994. ***************************************************************************}
  1995. constructor tsetdef.create(def:tdef;high : aint);
  1996. begin
  1997. inherited create(setdef);
  1998. elementdef:=def;
  1999. // setbase:=low;
  2000. setmax:=high;
  2001. if high<32 then
  2002. begin
  2003. settype:=smallset;
  2004. if current_settings.setalloc=0 then { $PACKSET Fixed?}
  2005. savesize:=Sizeof(longint)
  2006. else {No, use $PACKSET VALUE for rounding}
  2007. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  2008. end
  2009. else
  2010. if high<256 then
  2011. begin
  2012. settype:=normset;
  2013. if current_settings.setalloc=0 then { $PACKSET Fixed?}
  2014. savesize:=32
  2015. else {No, use $PACKSET VALUE for rounding}
  2016. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  2017. end
  2018. else
  2019. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  2020. end;
  2021. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2022. begin
  2023. inherited ppuload(setdef,ppufile);
  2024. ppufile.getderef(elementdefderef);
  2025. settype:=tsettype(ppufile.getbyte);
  2026. case settype of
  2027. normset : savesize:=32;
  2028. varset : savesize:=ppufile.getlongint;
  2029. smallset : savesize:=Sizeof(longint);
  2030. end;
  2031. end;
  2032. destructor tsetdef.destroy;
  2033. begin
  2034. inherited destroy;
  2035. end;
  2036. function tsetdef.getcopy : tstoreddef;
  2037. begin
  2038. case settype of
  2039. smallset:
  2040. result:=tsetdef.create(elementdef,31);
  2041. normset:
  2042. result:=tsetdef.create(elementdef,255);
  2043. else
  2044. internalerror(2004121202);
  2045. end;
  2046. end;
  2047. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2048. begin
  2049. inherited ppuwrite(ppufile);
  2050. ppufile.putderef(elementdefderef);
  2051. ppufile.putbyte(byte(settype));
  2052. if settype=varset then
  2053. ppufile.putlongint(savesize);
  2054. if settype=normset then
  2055. ppufile.putaint(savesize);
  2056. ppufile.writeentry(ibsetdef);
  2057. end;
  2058. procedure tsetdef.buildderef;
  2059. begin
  2060. inherited buildderef;
  2061. elementdefderef.build(elementdef);
  2062. end;
  2063. procedure tsetdef.deref;
  2064. begin
  2065. inherited deref;
  2066. elementdef:=tdef(elementdefderef.resolve);
  2067. end;
  2068. procedure tsetdef.write_child_rtti_data(rt:trttitype);
  2069. begin
  2070. tstoreddef(elementdef).get_rtti_label(rt);
  2071. end;
  2072. procedure tsetdef.write_rtti_data(rt:trttitype);
  2073. begin
  2074. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSet));
  2075. write_rtti_name;
  2076. {$ifdef cpurequiresproperalignment}
  2077. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  2078. {$endif cpurequiresproperalignment}
  2079. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otULong));
  2080. {$ifdef cpurequiresproperalignment}
  2081. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  2082. {$endif cpurequiresproperalignment}
  2083. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(elementdef).get_rtti_label(rt)));
  2084. end;
  2085. function tsetdef.is_publishable : boolean;
  2086. begin
  2087. is_publishable:=(settype=smallset);
  2088. end;
  2089. function tsetdef.GetTypeName : string;
  2090. begin
  2091. if assigned(elementdef) then
  2092. GetTypeName:='Set Of '+elementdef.typename
  2093. else
  2094. GetTypeName:='Empty Set';
  2095. end;
  2096. {***************************************************************************
  2097. TFORMALDEF
  2098. ***************************************************************************}
  2099. constructor tformaldef.create;
  2100. begin
  2101. inherited create(formaldef);
  2102. savesize:=0;
  2103. end;
  2104. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2105. begin
  2106. inherited ppuload(formaldef,ppufile);
  2107. savesize:=0;
  2108. end;
  2109. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2110. begin
  2111. inherited ppuwrite(ppufile);
  2112. ppufile.writeentry(ibformaldef);
  2113. end;
  2114. function tformaldef.GetTypeName : string;
  2115. begin
  2116. GetTypeName:='<Formal type>';
  2117. end;
  2118. {***************************************************************************
  2119. TARRAYDEF
  2120. ***************************************************************************}
  2121. constructor tarraydef.create(l,h : aint;def:tdef);
  2122. begin
  2123. inherited create(arraydef);
  2124. lowrange:=l;
  2125. highrange:=h;
  2126. rangedef:=def;
  2127. _elementdef:=nil;
  2128. arrayoptions:=[];
  2129. end;
  2130. constructor tarraydef.create_from_pointer(def:tdef);
  2131. begin
  2132. self.create(0,$7fffffff,s32inttype);
  2133. arrayoptions:=[ado_IsConvertedPointer];
  2134. setelementdef(def);
  2135. end;
  2136. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2137. begin
  2138. inherited ppuload(arraydef,ppufile);
  2139. { the addresses are calculated later }
  2140. ppufile.getderef(_elementdefderef);
  2141. ppufile.getderef(rangedefderef);
  2142. lowrange:=ppufile.getaint;
  2143. highrange:=ppufile.getaint;
  2144. ppufile.getsmallset(arrayoptions);
  2145. end;
  2146. function tarraydef.getcopy : tstoreddef;
  2147. begin
  2148. result:=tarraydef.create(lowrange,highrange,rangedef);
  2149. tarraydef(result).arrayoptions:=arrayoptions;
  2150. tarraydef(result)._elementdef:=_elementdef;
  2151. end;
  2152. procedure tarraydef.buildderef;
  2153. begin
  2154. inherited buildderef;
  2155. _elementdefderef.build(_elementdef);
  2156. rangedefderef.build(rangedef);
  2157. end;
  2158. procedure tarraydef.deref;
  2159. begin
  2160. inherited deref;
  2161. _elementdef:=tdef(_elementdefderef.resolve);
  2162. rangedef:=tdef(rangedefderef.resolve);
  2163. end;
  2164. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2165. begin
  2166. inherited ppuwrite(ppufile);
  2167. ppufile.putderef(_elementdefderef);
  2168. ppufile.putderef(rangedefderef);
  2169. ppufile.putaint(lowrange);
  2170. ppufile.putaint(highrange);
  2171. ppufile.putsmallset(arrayoptions);
  2172. ppufile.writeentry(ibarraydef);
  2173. end;
  2174. function tarraydef.elesize : aint;
  2175. begin
  2176. if (ado_IsBitPacked in arrayoptions) then
  2177. internalerror(2006080101);
  2178. if assigned(_elementdef) then
  2179. result:=_elementdef.size
  2180. else
  2181. result:=0;
  2182. end;
  2183. function tarraydef.elepackedbitsize : aint;
  2184. begin
  2185. if not(ado_IsBitPacked in arrayoptions) then
  2186. internalerror(2006080102);
  2187. if assigned(_elementdef) then
  2188. result:=_elementdef.packedbitsize
  2189. else
  2190. result:=0;
  2191. end;
  2192. function tarraydef.elecount : aint;
  2193. var
  2194. qhigh,qlow : qword;
  2195. begin
  2196. if ado_IsDynamicArray in arrayoptions then
  2197. begin
  2198. result:=0;
  2199. exit;
  2200. end;
  2201. if (highrange>0) and (lowrange<0) then
  2202. begin
  2203. qhigh:=highrange;
  2204. qlow:=qword(-lowrange);
  2205. { prevent overflow, return -1 to indicate overflow }
  2206. if qhigh+qlow>qword(high(aint)-1) then
  2207. result:=-1
  2208. else
  2209. result:=qhigh+qlow+1;
  2210. end
  2211. else
  2212. result:=int64(highrange)-lowrange+1;
  2213. end;
  2214. function tarraydef.size : aint;
  2215. var
  2216. cachedelecount,
  2217. cachedelesize : aint;
  2218. begin
  2219. if ado_IsDynamicArray in arrayoptions then
  2220. begin
  2221. size:=sizeof(aint);
  2222. exit;
  2223. end;
  2224. { Tarraydef.size may never be called for an open array! }
  2225. if highrange<lowrange then
  2226. internalerror(99080501);
  2227. if not (ado_IsBitPacked in arrayoptions) then
  2228. cachedelesize:=elesize
  2229. else
  2230. cachedelesize := elepackedbitsize;
  2231. cachedelecount:=elecount;
  2232. if (cachedelesize = 0) then
  2233. begin
  2234. size := 0;
  2235. exit;
  2236. end;
  2237. if (cachedelecount = -1) then
  2238. begin
  2239. size := -1;
  2240. exit;
  2241. end;
  2242. { prevent overflow, return -1 to indicate overflow }
  2243. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  2244. if (cachedelecount > high(aint)) or
  2245. ((high(aint) div cachedelesize) < cachedelecount) or
  2246. { also lowrange*elesize must be < high(aint) to prevent overflow when
  2247. accessing the array, see ncgmem (PFV) }
  2248. ((high(aint) div cachedelesize) < abs(lowrange)) then
  2249. begin
  2250. result:=-1;
  2251. exit;
  2252. end;
  2253. if (ado_IsBitPacked in arrayoptions) then
  2254. size:=(cachedelesize * cachedelecount + 7) div 8
  2255. else
  2256. result:=cachedelesize*cachedelecount;
  2257. end;
  2258. procedure tarraydef.setelementdef(def:tdef);
  2259. begin
  2260. _elementdef:=def;
  2261. if not(
  2262. (ado_IsDynamicArray in arrayoptions) or
  2263. (ado_IsConvertedPointer in arrayoptions) or
  2264. (highrange<lowrange)
  2265. ) and
  2266. (size=-1) then
  2267. Message(sym_e_segment_too_large);
  2268. end;
  2269. function tarraydef.alignment : shortint;
  2270. begin
  2271. { alignment is the size of the elements }
  2272. if (elementdef.deftype in [arraydef,recorddef]) or
  2273. ((elementdef.deftype=objectdef) and
  2274. is_object(elementdef)) then
  2275. alignment:=elementdef.alignment
  2276. else if not (ado_IsBitPacked in arrayoptions) then
  2277. alignment:=size_2_align(elesize)
  2278. else
  2279. alignment:=packedbitsloadsize(elepackedbitsize);
  2280. end;
  2281. function tarraydef.needs_inittable : boolean;
  2282. begin
  2283. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  2284. end;
  2285. procedure tarraydef.write_child_rtti_data(rt:trttitype);
  2286. begin
  2287. tstoreddef(elementdef).get_rtti_label(rt);
  2288. end;
  2289. procedure tarraydef.write_rtti_data(rt:trttitype);
  2290. begin
  2291. if ado_IsBitPacked in arrayoptions then
  2292. begin
  2293. current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
  2294. write_rtti_name;
  2295. exit;
  2296. end;
  2297. if ado_IsDynamicArray in arrayoptions then
  2298. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkdynarray))
  2299. else
  2300. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkarray));
  2301. write_rtti_name;
  2302. {$ifdef cpurequiresproperalignment}
  2303. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  2304. {$endif cpurequiresproperalignment}
  2305. { size of elements }
  2306. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(elesize));
  2307. if not(ado_IsDynamicArray in arrayoptions) then
  2308. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(elecount));
  2309. { element type }
  2310. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(elementdef).get_rtti_label(rt)));
  2311. { variant type }
  2312. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tstoreddef(elementdef).getvardef));
  2313. end;
  2314. function tarraydef.GetTypeName : string;
  2315. begin
  2316. if (ado_IsConstString in arrayoptions) then
  2317. result:='Constant String'
  2318. else if (ado_isarrayofconst in arrayoptions) or
  2319. (ado_isConstructor in arrayoptions) then
  2320. begin
  2321. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  2322. GetTypeName:='Array Of Const'
  2323. else
  2324. GetTypeName:='Array Of '+elementdef.typename;
  2325. end
  2326. else if ((highrange=-1) and (lowrange=0)) or (ado_IsDynamicArray in arrayoptions) then
  2327. GetTypeName:='Array Of '+elementdef.typename
  2328. else
  2329. begin
  2330. result := '';
  2331. if (ado_IsBitPacked in arrayoptions) then
  2332. result:='Packed ';
  2333. if rangedef.deftype=enumdef then
  2334. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2335. else
  2336. result:=result+'Array['+tostr(lowrange)+'..'+
  2337. tostr(highrange)+'] Of '+elementdef.typename
  2338. end;
  2339. end;
  2340. function tarraydef.getmangledparaname : string;
  2341. begin
  2342. if ado_isarrayofconst in arrayoptions then
  2343. getmangledparaname:='array_of_const'
  2344. else
  2345. if ((highrange=-1) and (lowrange=0)) then
  2346. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2347. else
  2348. internalerror(200204176);
  2349. end;
  2350. {***************************************************************************
  2351. tabstractrecorddef
  2352. ***************************************************************************}
  2353. function tabstractrecorddef.getsymtable(t:tgetsymtable):tsymtable;
  2354. begin
  2355. if t=gs_record then
  2356. getsymtable:=symtable
  2357. else
  2358. getsymtable:=nil;
  2359. end;
  2360. procedure tabstractrecorddef.reset;
  2361. begin
  2362. inherited reset;
  2363. tstoredsymtable(symtable).reset_all_defs;
  2364. end;
  2365. function tabstractrecorddef.is_packed:boolean;
  2366. begin
  2367. result:=tabstractrecordsymtable(symtable).is_packed;
  2368. end;
  2369. procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
  2370. begin
  2371. if (FRTTIType=fullrtti) or
  2372. ((tsym(sym).typ=fieldvarsym) and
  2373. tfieldvarsym(sym).vardef.needs_inittable) then
  2374. inc(Count);
  2375. end;
  2376. procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
  2377. begin
  2378. if (FRTTIType=fullrtti) or
  2379. ((tsym(sym).typ=fieldvarsym) and
  2380. tfieldvarsym(sym).vardef.needs_inittable) then
  2381. tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(FRTTIType);
  2382. end;
  2383. procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
  2384. begin
  2385. if (FRTTIType=fullrtti) or
  2386. ((tsym(sym).typ=fieldvarsym) and
  2387. tfieldvarsym(sym).vardef.needs_inittable) then
  2388. begin
  2389. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(FRTTIType)));
  2390. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tfieldvarsym(sym).fieldoffset));
  2391. end;
  2392. end;
  2393. {***************************************************************************
  2394. trecorddef
  2395. ***************************************************************************}
  2396. constructor trecorddef.create(p : tsymtable);
  2397. begin
  2398. inherited create(recorddef);
  2399. symtable:=p;
  2400. symtable.defowner:=self;
  2401. isunion:=false;
  2402. end;
  2403. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2404. begin
  2405. inherited ppuload(recorddef,ppufile);
  2406. symtable:=trecordsymtable.create(0);
  2407. trecordsymtable(symtable).datasize:=ppufile.getaint;
  2408. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2409. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2410. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2411. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2412. trecordsymtable(symtable).ppuload(ppufile);
  2413. symtable.defowner:=self;
  2414. isunion:=false;
  2415. end;
  2416. destructor trecorddef.destroy;
  2417. begin
  2418. if assigned(symtable) then
  2419. symtable.free;
  2420. inherited destroy;
  2421. end;
  2422. function trecorddef.getcopy : tstoreddef;
  2423. begin
  2424. result:=trecorddef.create(symtable.getcopy);
  2425. trecorddef(result).isunion:=isunion;
  2426. end;
  2427. function trecorddef.needs_inittable : boolean;
  2428. begin
  2429. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2430. end;
  2431. procedure trecorddef.buildderef;
  2432. var
  2433. oldrecsyms : tsymtable;
  2434. begin
  2435. inherited buildderef;
  2436. oldrecsyms:=aktrecordsymtable;
  2437. aktrecordsymtable:=symtable;
  2438. { now build the definitions }
  2439. tstoredsymtable(symtable).buildderef;
  2440. aktrecordsymtable:=oldrecsyms;
  2441. end;
  2442. procedure trecorddef.deref;
  2443. var
  2444. oldrecsyms : tsymtable;
  2445. begin
  2446. inherited deref;
  2447. oldrecsyms:=aktrecordsymtable;
  2448. aktrecordsymtable:=symtable;
  2449. { now dereference the definitions }
  2450. tstoredsymtable(symtable).deref;
  2451. aktrecordsymtable:=oldrecsyms;
  2452. { assign TGUID? load only from system unit }
  2453. if not(assigned(rec_tguid)) and
  2454. (upper(typename)='TGUID') and
  2455. assigned(owner) and
  2456. assigned(owner.name) and
  2457. (owner.name^='SYSTEM') then
  2458. rec_tguid:=self;
  2459. end;
  2460. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2461. begin
  2462. inherited ppuwrite(ppufile);
  2463. ppufile.putaint(trecordsymtable(symtable).datasize);
  2464. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  2465. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  2466. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  2467. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  2468. ppufile.writeentry(ibrecorddef);
  2469. trecordsymtable(symtable).ppuwrite(ppufile);
  2470. end;
  2471. function trecorddef.size:aint;
  2472. begin
  2473. result:=trecordsymtable(symtable).datasize;
  2474. end;
  2475. function trecorddef.alignment:shortint;
  2476. begin
  2477. alignment:=trecordsymtable(symtable).recordalignment;
  2478. end;
  2479. function trecorddef.padalignment:shortint;
  2480. begin
  2481. padalignment := trecordsymtable(symtable).padalignment;
  2482. end;
  2483. procedure trecorddef.write_child_rtti_data(rt:trttitype);
  2484. begin
  2485. FRTTIType:=rt;
  2486. symtable.foreach(@generate_field_rtti,nil);
  2487. end;
  2488. procedure trecorddef.write_rtti_data(rt:trttitype);
  2489. begin
  2490. if is_packed then
  2491. begin
  2492. current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
  2493. write_rtti_name;
  2494. exit;
  2495. end;
  2496. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkrecord));
  2497. write_rtti_name;
  2498. {$ifdef cpurequiresproperalignment}
  2499. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  2500. {$endif cpurequiresproperalignment}
  2501. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(size));
  2502. Count:=0;
  2503. FRTTIType:=rt;
  2504. symtable.foreach(@count_field_rtti,nil);
  2505. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(Count));
  2506. symtable.foreach(@write_field_rtti,nil);
  2507. end;
  2508. function trecorddef.GetTypeName : string;
  2509. begin
  2510. GetTypeName:='<record type>'
  2511. end;
  2512. {***************************************************************************
  2513. TABSTRACTPROCDEF
  2514. ***************************************************************************}
  2515. constructor tabstractprocdef.create(dt:tdeftype;level:byte);
  2516. begin
  2517. inherited create(dt);
  2518. parast:=tparasymtable.create(level);
  2519. parast.defowner:=self;
  2520. paras:=nil;
  2521. minparacount:=0;
  2522. maxparacount:=0;
  2523. proctypeoption:=potype_none;
  2524. proccalloption:=pocall_none;
  2525. procoptions:=[];
  2526. returndef:=voidtype;
  2527. {$ifdef i386}
  2528. fpu_used:=0;
  2529. {$endif i386}
  2530. savesize:=sizeof(aint);
  2531. requiredargarea:=0;
  2532. has_paraloc_info:=false;
  2533. location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
  2534. location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
  2535. end;
  2536. destructor tabstractprocdef.destroy;
  2537. begin
  2538. if assigned(paras) then
  2539. begin
  2540. {$ifdef MEMDEBUG}
  2541. memprocpara.start;
  2542. {$endif MEMDEBUG}
  2543. paras.free;
  2544. {$ifdef MEMDEBUG}
  2545. memprocpara.stop;
  2546. {$endif MEMDEBUG}
  2547. end;
  2548. if assigned(parast) then
  2549. begin
  2550. {$ifdef MEMDEBUG}
  2551. memprocparast.start;
  2552. {$endif MEMDEBUG}
  2553. parast.free;
  2554. {$ifdef MEMDEBUG}
  2555. memprocparast.stop;
  2556. {$endif MEMDEBUG}
  2557. end;
  2558. inherited destroy;
  2559. end;
  2560. procedure tabstractprocdef.releasemem;
  2561. begin
  2562. if assigned(paras) then
  2563. begin
  2564. paras.free;
  2565. paras:=nil;
  2566. end;
  2567. parast.free;
  2568. parast:=nil;
  2569. end;
  2570. procedure tabstractprocdef.count_para(p:tnamedindexitem;arg:pointer);
  2571. begin
  2572. if (tsym(p).typ<>paravarsym) then
  2573. exit;
  2574. inc(plongint(arg)^);
  2575. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  2576. begin
  2577. if not assigned(tparavarsym(p).defaultconstsym) then
  2578. inc(minparacount);
  2579. inc(maxparacount);
  2580. end;
  2581. end;
  2582. procedure tabstractprocdef.insert_para(p:tnamedindexitem;arg:pointer);
  2583. begin
  2584. if (tsym(p).typ<>paravarsym) then
  2585. exit;
  2586. paras.add(p);
  2587. end;
  2588. procedure tabstractprocdef.calcparas;
  2589. var
  2590. paracount : longint;
  2591. begin
  2592. { This can already be assigned when
  2593. we need to reresolve this unit (PFV) }
  2594. if assigned(paras) then
  2595. paras.free;
  2596. paras:=tparalist.create(false);
  2597. paracount:=0;
  2598. minparacount:=0;
  2599. maxparacount:=0;
  2600. parast.foreach(@count_para,@paracount);
  2601. paras.capacity:=paracount;
  2602. { Insert parameters in table }
  2603. parast.foreach(@insert_para,nil);
  2604. { Order parameters }
  2605. paras.sortparas;
  2606. end;
  2607. { all functions returning in FPU are
  2608. assume to use 2 FPU registers
  2609. until the function implementation
  2610. is processed PM }
  2611. procedure tabstractprocdef.test_if_fpu_result;
  2612. begin
  2613. {$ifdef i386}
  2614. if assigned(returndef) and
  2615. (returndef.deftype=floatdef) then
  2616. fpu_used:=maxfpuregs;
  2617. {$endif i386}
  2618. end;
  2619. procedure tabstractprocdef.buildderef;
  2620. begin
  2621. { released procdef? }
  2622. if not assigned(parast) then
  2623. exit;
  2624. inherited buildderef;
  2625. returndefderef.build(returndef);
  2626. { parast }
  2627. tparasymtable(parast).buildderef;
  2628. end;
  2629. procedure tabstractprocdef.deref;
  2630. begin
  2631. inherited deref;
  2632. returndef:=tdef(returndefderef.resolve);
  2633. { parast }
  2634. tparasymtable(parast).deref;
  2635. { recalculated parameters }
  2636. calcparas;
  2637. end;
  2638. constructor tabstractprocdef.ppuload(dt:tdeftype;ppufile:tcompilerppufile);
  2639. var
  2640. b : byte;
  2641. begin
  2642. inherited ppuload(dt,ppufile);
  2643. parast:=nil;
  2644. Paras:=nil;
  2645. minparacount:=0;
  2646. maxparacount:=0;
  2647. ppufile.getderef(returndefderef);
  2648. {$ifdef i386}
  2649. fpu_used:=ppufile.getbyte;
  2650. {$else}
  2651. ppufile.getbyte;
  2652. {$endif i386}
  2653. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2654. proccalloption:=tproccalloption(ppufile.getbyte);
  2655. ppufile.getnormalset(procoptions);
  2656. location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
  2657. location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
  2658. if po_explicitparaloc in procoptions then
  2659. begin
  2660. b:=ppufile.getbyte;
  2661. if b<>sizeof(funcretloc[callerside]) then
  2662. internalerror(200411154);
  2663. ppufile.getdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
  2664. end;
  2665. savesize:=sizeof(aint);
  2666. has_paraloc_info:=(po_explicitparaloc in procoptions);
  2667. end;
  2668. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  2669. var
  2670. oldintfcrc : boolean;
  2671. begin
  2672. { released procdef? }
  2673. if not assigned(parast) then
  2674. exit;
  2675. inherited ppuwrite(ppufile);
  2676. ppufile.putderef(returndefderef);
  2677. oldintfcrc:=ppufile.do_interface_crc;
  2678. ppufile.do_interface_crc:=false;
  2679. {$ifdef i386}
  2680. if simplify_ppu then
  2681. fpu_used:=0;
  2682. ppufile.putbyte(fpu_used);
  2683. {$else}
  2684. ppufile.putbyte(0);
  2685. {$endif}
  2686. ppufile.putbyte(ord(proctypeoption));
  2687. ppufile.putbyte(ord(proccalloption));
  2688. ppufile.putnormalset(procoptions);
  2689. ppufile.do_interface_crc:=oldintfcrc;
  2690. if (po_explicitparaloc in procoptions) then
  2691. begin
  2692. { Make a 'valid' funcretloc for procedures }
  2693. ppufile.putbyte(sizeof(funcretloc[callerside]));
  2694. ppufile.putdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
  2695. end;
  2696. end;
  2697. function tabstractprocdef.typename_paras(showhidden:boolean) : string;
  2698. var
  2699. hs,s : string;
  2700. hp : TParavarsym;
  2701. hpc : tconstsym;
  2702. first : boolean;
  2703. i : integer;
  2704. begin
  2705. s:='';
  2706. first:=true;
  2707. for i:=0 to paras.count-1 do
  2708. begin
  2709. hp:=tparavarsym(paras[i]);
  2710. if not(vo_is_hidden_para in hp.varoptions) or
  2711. (showhidden) then
  2712. begin
  2713. if first then
  2714. begin
  2715. s:=s+'(';
  2716. first:=false;
  2717. end
  2718. else
  2719. s:=s+',';
  2720. if vo_is_hidden_para in hp.varoptions then
  2721. s:=s+'<';
  2722. case hp.varspez of
  2723. vs_var :
  2724. s:=s+'var';
  2725. vs_const :
  2726. s:=s+'const';
  2727. vs_out :
  2728. s:=s+'out';
  2729. end;
  2730. if assigned(hp.vardef.typesym) then
  2731. begin
  2732. if s<>'(' then
  2733. s:=s+' ';
  2734. hs:=hp.vardef.typesym.realname;
  2735. if hs[1]<>'$' then
  2736. s:=s+hp.vardef.typesym.realname
  2737. else
  2738. s:=s+hp.vardef.GetTypeName;
  2739. end
  2740. else
  2741. s:=s+hp.vardef.GetTypeName;
  2742. { default value }
  2743. if assigned(hp.defaultconstsym) then
  2744. begin
  2745. hpc:=tconstsym(hp.defaultconstsym);
  2746. hs:='';
  2747. case hpc.consttyp of
  2748. conststring,
  2749. constresourcestring :
  2750. hs:=strpas(pchar(hpc.value.valueptr));
  2751. constreal :
  2752. str(pbestreal(hpc.value.valueptr)^,hs);
  2753. constpointer :
  2754. hs:=tostr(hpc.value.valueordptr);
  2755. constord :
  2756. begin
  2757. if is_boolean(hpc.constdef) then
  2758. begin
  2759. if hpc.value.valueord<>0 then
  2760. hs:='TRUE'
  2761. else
  2762. hs:='FALSE';
  2763. end
  2764. else
  2765. hs:=tostr(hpc.value.valueord);
  2766. end;
  2767. constnil :
  2768. hs:='nil';
  2769. constset :
  2770. hs:='<set>';
  2771. end;
  2772. if hs<>'' then
  2773. s:=s+'="'+hs+'"';
  2774. end;
  2775. if vo_is_hidden_para in hp.varoptions then
  2776. s:=s+'>';
  2777. end;
  2778. end;
  2779. if not first then
  2780. s:=s+')';
  2781. if (po_varargs in procoptions) then
  2782. s:=s+';VarArgs';
  2783. typename_paras:=s;
  2784. end;
  2785. function tabstractprocdef.is_methodpointer:boolean;
  2786. begin
  2787. result:=false;
  2788. end;
  2789. function tabstractprocdef.is_addressonly:boolean;
  2790. begin
  2791. result:=true;
  2792. end;
  2793. {***************************************************************************
  2794. TPROCDEF
  2795. ***************************************************************************}
  2796. constructor tprocdef.create(level:byte);
  2797. begin
  2798. inherited create(procdef,level);
  2799. _mangledname:=nil;
  2800. fileinfo:=current_filepos;
  2801. extnumber:=$ffff;
  2802. aliasnames:=tstringlist.create;
  2803. funcretsym:=nil;
  2804. localst := nil;
  2805. defref:=nil;
  2806. lastwritten:=nil;
  2807. refcount:=0;
  2808. if (cs_browser in current_settings.moduleswitches) and make_ref then
  2809. begin
  2810. defref:=tref.create(defref,@current_tokenpos);
  2811. inc(refcount);
  2812. end;
  2813. lastref:=defref;
  2814. forwarddef:=true;
  2815. interfacedef:=false;
  2816. hasforward:=false;
  2817. _class := nil;
  2818. import_dll:=nil;
  2819. import_name:=nil;
  2820. import_nr:=0;
  2821. inlininginfo:=nil;
  2822. end;
  2823. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  2824. var
  2825. level : byte;
  2826. begin
  2827. inherited ppuload(procdef,ppufile);
  2828. if po_has_mangledname in procoptions then
  2829. _mangledname:=stringdup(ppufile.getstring)
  2830. else
  2831. _mangledname:=nil;
  2832. extnumber:=ppufile.getword;
  2833. level:=ppufile.getbyte;
  2834. ppufile.getderef(_classderef);
  2835. ppufile.getderef(procsymderef);
  2836. ppufile.getposinfo(fileinfo);
  2837. ppufile.getsmallset(symoptions);
  2838. {$ifdef powerpc}
  2839. { library symbol for AmigaOS/MorphOS }
  2840. ppufile.getderef(libsymderef);
  2841. {$endif powerpc}
  2842. { import stuff }
  2843. if po_has_importdll in procoptions then
  2844. import_dll:=stringdup(ppufile.getstring)
  2845. else
  2846. import_dll:=nil;
  2847. if po_has_importname in procoptions then
  2848. import_name:=stringdup(ppufile.getstring)
  2849. else
  2850. import_name:=nil;
  2851. import_nr:=ppufile.getword;
  2852. if (po_msgint in procoptions) then
  2853. messageinf.i:=ppufile.getlongint;
  2854. if (po_msgstr in procoptions) then
  2855. messageinf.str:=stringdup(ppufile.getstring);
  2856. { inline stuff }
  2857. if (po_has_inlininginfo in procoptions) then
  2858. begin
  2859. ppufile.getderef(funcretsymderef);
  2860. new(inlininginfo);
  2861. ppufile.getsmallset(inlininginfo^.flags);
  2862. end
  2863. else
  2864. begin
  2865. inlininginfo:=nil;
  2866. funcretsym:=nil;
  2867. end;
  2868. { load para symtable }
  2869. parast:=tparasymtable.create(level);
  2870. tparasymtable(parast).ppuload(ppufile);
  2871. parast.defowner:=self;
  2872. { load local symtable }
  2873. if (po_has_inlininginfo in procoptions) or
  2874. ((current_module.flags and uf_local_browser)<>0) then
  2875. begin
  2876. localst:=tlocalsymtable.create(level);
  2877. tlocalsymtable(localst).ppuload(ppufile);
  2878. localst.defowner:=self;
  2879. end
  2880. else
  2881. localst:=nil;
  2882. { inline stuff }
  2883. if (po_has_inlininginfo in procoptions) then
  2884. inlininginfo^.code:=ppuloadnodetree(ppufile);
  2885. { default values for no persistent data }
  2886. if (cs_link_deffile in current_settings.globalswitches) and
  2887. (tf_need_export in target_info.flags) and
  2888. (po_exports in procoptions) then
  2889. deffile.AddExport(mangledname);
  2890. aliasnames:=tstringlist.create;
  2891. forwarddef:=false;
  2892. interfacedef:=false;
  2893. hasforward:=false;
  2894. lastref:=nil;
  2895. lastwritten:=nil;
  2896. defref:=nil;
  2897. refcount:=0;
  2898. { Disable po_has_inlining until the derefimpl is done }
  2899. exclude(procoptions,po_has_inlininginfo);
  2900. end;
  2901. destructor tprocdef.destroy;
  2902. begin
  2903. if assigned(defref) then
  2904. begin
  2905. defref.freechain;
  2906. defref.free;
  2907. end;
  2908. aliasnames.free;
  2909. if assigned(localst) and (localst.symtabletype<>staticsymtable) then
  2910. begin
  2911. {$ifdef MEMDEBUG}
  2912. memproclocalst.start;
  2913. {$endif MEMDEBUG}
  2914. localst.free;
  2915. {$ifdef MEMDEBUG}
  2916. memproclocalst.start;
  2917. {$endif MEMDEBUG}
  2918. end;
  2919. if assigned(inlininginfo) then
  2920. begin
  2921. {$ifdef MEMDEBUG}
  2922. memprocnodetree.start;
  2923. {$endif MEMDEBUG}
  2924. tnode(inlininginfo^.code).free;
  2925. {$ifdef MEMDEBUG}
  2926. memprocnodetree.start;
  2927. {$endif MEMDEBUG}
  2928. dispose(inlininginfo);
  2929. end;
  2930. stringdispose(import_dll);
  2931. stringdispose(import_name);
  2932. if (po_msgstr in procoptions) then
  2933. stringdispose(messageinf.str);
  2934. if assigned(_mangledname) then
  2935. begin
  2936. {$ifdef MEMDEBUG}
  2937. memmanglednames.start;
  2938. {$endif MEMDEBUG}
  2939. stringdispose(_mangledname);
  2940. {$ifdef MEMDEBUG}
  2941. memmanglednames.stop;
  2942. {$endif MEMDEBUG}
  2943. end;
  2944. inherited destroy;
  2945. end;
  2946. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  2947. var
  2948. oldintfcrc : boolean;
  2949. oldparasymtable,
  2950. oldlocalsymtable : tsymtable;
  2951. begin
  2952. { released procdef? }
  2953. if not assigned(parast) then
  2954. exit;
  2955. oldparasymtable:=aktparasymtable;
  2956. oldlocalsymtable:=aktlocalsymtable;
  2957. aktparasymtable:=parast;
  2958. aktlocalsymtable:=localst;
  2959. inherited ppuwrite(ppufile);
  2960. if po_has_mangledname in procoptions then
  2961. ppufile.putstring(_mangledname^);
  2962. ppufile.putword(extnumber);
  2963. ppufile.putbyte(parast.symtablelevel);
  2964. ppufile.putderef(_classderef);
  2965. ppufile.putderef(procsymderef);
  2966. ppufile.putposinfo(fileinfo);
  2967. ppufile.putsmallset(symoptions);
  2968. {$ifdef powerpc}
  2969. { library symbol for AmigaOS/MorphOS }
  2970. ppufile.putderef(libsymderef);
  2971. {$endif powerpc}
  2972. { import }
  2973. if po_has_importdll in procoptions then
  2974. ppufile.putstring(import_dll^);
  2975. if po_has_importname in procoptions then
  2976. ppufile.putstring(import_name^);
  2977. ppufile.putword(import_nr);
  2978. if (po_msgint in procoptions) then
  2979. ppufile.putlongint(messageinf.i);
  2980. if (po_msgstr in procoptions) then
  2981. ppufile.putstring(messageinf.str^);
  2982. { inline stuff }
  2983. oldintfcrc:=ppufile.do_crc;
  2984. ppufile.do_crc:=false;
  2985. if (po_has_inlininginfo in procoptions) then
  2986. begin
  2987. ppufile.putderef(funcretsymderef);
  2988. ppufile.putsmallset(inlininginfo^.flags);
  2989. end;
  2990. ppufile.do_crc:=oldintfcrc;
  2991. { write this entry }
  2992. ppufile.writeentry(ibprocdef);
  2993. { Save the para symtable, this is taken from the interface }
  2994. tparasymtable(parast).ppuwrite(ppufile);
  2995. { save localsymtable for inline procedures or when local
  2996. browser info is requested, this has no influence on the crc }
  2997. if (po_has_inlininginfo in procoptions) or
  2998. ((current_module.flags and uf_local_browser)<>0) then
  2999. begin
  3000. { we must write a localsymtable }
  3001. if not assigned(localst) then
  3002. insert_localst;
  3003. oldintfcrc:=ppufile.do_crc;
  3004. ppufile.do_crc:=false;
  3005. tlocalsymtable(localst).ppuwrite(ppufile);
  3006. ppufile.do_crc:=oldintfcrc;
  3007. end;
  3008. { node tree for inlining }
  3009. oldintfcrc:=ppufile.do_crc;
  3010. ppufile.do_crc:=false;
  3011. if (po_has_inlininginfo in procoptions) then
  3012. ppuwritenodetree(ppufile,inlininginfo^.code);
  3013. ppufile.do_crc:=oldintfcrc;
  3014. aktparasymtable:=oldparasymtable;
  3015. aktlocalsymtable:=oldlocalsymtable;
  3016. end;
  3017. procedure tprocdef.reset;
  3018. begin
  3019. inherited reset;
  3020. procstarttai:=nil;
  3021. procendtai:=nil;
  3022. end;
  3023. procedure tprocdef.insert_localst;
  3024. begin
  3025. localst:=tlocalsymtable.create(parast.symtablelevel);
  3026. localst.defowner:=self;
  3027. end;
  3028. function tprocdef.fullprocname(showhidden:boolean):string;
  3029. var
  3030. s : string;
  3031. t : ttoken;
  3032. begin
  3033. {$ifdef EXTDEBUG}
  3034. showhidden:=true;
  3035. {$endif EXTDEBUG}
  3036. s:='';
  3037. if owner.symtabletype=localsymtable then
  3038. s:=s+'local ';
  3039. if assigned(_class) then
  3040. begin
  3041. if po_classmethod in procoptions then
  3042. s:=s+'class ';
  3043. s:=s+_class.objrealname^+'.';
  3044. end;
  3045. if proctypeoption=potype_operator then
  3046. begin
  3047. for t:=NOTOKEN to last_overloaded do
  3048. if procsym.realname='$'+overloaded_names[t] then
  3049. begin
  3050. s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
  3051. break;
  3052. end;
  3053. end
  3054. else
  3055. s:=s+procsym.realname+typename_paras(showhidden);
  3056. case proctypeoption of
  3057. potype_constructor:
  3058. s:='constructor '+s;
  3059. potype_destructor:
  3060. s:='destructor '+s;
  3061. else
  3062. if assigned(returndef) and
  3063. not(is_void(returndef)) then
  3064. s:=s+':'+returndef.GetTypeName;
  3065. end;
  3066. { forced calling convention? }
  3067. if (po_hascallingconvention in procoptions) then
  3068. s:=s+';'+ProcCallOptionStr[proccalloption];
  3069. fullprocname:=s;
  3070. end;
  3071. function tprocdef.is_methodpointer:boolean;
  3072. begin
  3073. result:=assigned(_class);
  3074. end;
  3075. function tprocdef.is_addressonly:boolean;
  3076. begin
  3077. result:=assigned(owner) and
  3078. (owner.symtabletype<>objectsymtable);
  3079. end;
  3080. function tprocdef.is_visible_for_object(currobjdef,contextobjdef:tobjectdef):boolean;
  3081. var
  3082. contextst : tsymtable;
  3083. begin
  3084. result:=false;
  3085. { Support passing a context in which module we are to find protected members }
  3086. if assigned(contextobjdef) then
  3087. contextst:=contextobjdef.owner
  3088. else
  3089. contextst:=nil;
  3090. { private symbols are allowed when we are in the same
  3091. module as they are defined }
  3092. if (sp_private in symoptions) and
  3093. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  3094. not(owner.defowner.owner.iscurrentunit or (owner.defowner.owner=contextst)) then
  3095. exit;
  3096. if (sp_strictprivate in symoptions) then
  3097. begin
  3098. result:=currobjdef=tobjectdef(owner.defowner);
  3099. exit;
  3100. end;
  3101. if (sp_strictprotected in symoptions) then
  3102. begin
  3103. result:=assigned(currobjdef) and
  3104. currobjdef.is_related(tobjectdef(owner.defowner));
  3105. exit;
  3106. end;
  3107. { protected symbols are visible in the module that defines them and
  3108. also visible to related objects. The related object must be defined
  3109. in the current module }
  3110. if (sp_protected in symoptions) and
  3111. (
  3112. (
  3113. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  3114. not((owner.defowner.owner.iscurrentunit) or (owner.defowner.owner=contextst))
  3115. ) and
  3116. not(
  3117. assigned(currobjdef) and
  3118. (currobjdef.owner.symtabletype in [globalsymtable,staticsymtable]) and
  3119. (currobjdef.owner.iscurrentunit) and
  3120. currobjdef.is_related(tobjectdef(owner.defowner))
  3121. )
  3122. ) then
  3123. exit;
  3124. result:=true;
  3125. end;
  3126. function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
  3127. begin
  3128. case t of
  3129. gs_local :
  3130. getsymtable:=localst;
  3131. gs_para :
  3132. getsymtable:=parast;
  3133. else
  3134. getsymtable:=nil;
  3135. end;
  3136. end;
  3137. procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
  3138. var
  3139. pos : tfileposinfo;
  3140. move_last : boolean;
  3141. oldparasymtable,
  3142. oldlocalsymtable : tsymtable;
  3143. begin
  3144. oldparasymtable:=aktparasymtable;
  3145. oldlocalsymtable:=aktlocalsymtable;
  3146. aktparasymtable:=parast;
  3147. aktlocalsymtable:=localst;
  3148. move_last:=lastwritten=lastref;
  3149. while (not ppufile.endofentry) do
  3150. begin
  3151. ppufile.getposinfo(pos);
  3152. inc(refcount);
  3153. lastref:=tref.create(lastref,@pos);
  3154. lastref.is_written:=true;
  3155. if refcount=1 then
  3156. defref:=lastref;
  3157. end;
  3158. if move_last then
  3159. lastwritten:=lastref;
  3160. if ((current_module.flags and uf_local_browser)<>0) and
  3161. assigned(localst) and
  3162. locals then
  3163. begin
  3164. tparasymtable(parast).load_references(ppufile,locals);
  3165. tlocalsymtable(localst).load_references(ppufile,locals);
  3166. end;
  3167. aktparasymtable:=oldparasymtable;
  3168. aktlocalsymtable:=oldlocalsymtable;
  3169. end;
  3170. Const
  3171. local_symtable_index : word = $8001;
  3172. function tprocdef.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  3173. var
  3174. ref : tref;
  3175. {$ifdef supportbrowser}
  3176. pdo : tobjectdef;
  3177. {$endif supportbrowser}
  3178. move_last : boolean;
  3179. d : tderef;
  3180. oldparasymtable,
  3181. oldlocalsymtable : tsymtable;
  3182. begin
  3183. d.reset;
  3184. move_last:=lastwritten=lastref;
  3185. if move_last and
  3186. (((current_module.flags and uf_local_browser)=0) or
  3187. not locals) then
  3188. exit;
  3189. oldparasymtable:=aktparasymtable;
  3190. oldlocalsymtable:=aktlocalsymtable;
  3191. aktparasymtable:=parast;
  3192. aktlocalsymtable:=localst;
  3193. { write address of this symbol }
  3194. d.build(self);
  3195. ppufile.putderef(d);
  3196. { write refs }
  3197. if assigned(lastwritten) then
  3198. ref:=lastwritten
  3199. else
  3200. ref:=defref;
  3201. while assigned(ref) do
  3202. begin
  3203. if ref.moduleindex=current_module.unit_index then
  3204. begin
  3205. ppufile.putposinfo(ref.posinfo);
  3206. ref.is_written:=true;
  3207. if move_last then
  3208. lastwritten:=ref;
  3209. end
  3210. else if not ref.is_written then
  3211. move_last:=false
  3212. else if move_last then
  3213. lastwritten:=ref;
  3214. ref:=ref.nextref;
  3215. end;
  3216. ppufile.writeentry(ibdefref);
  3217. write_references:=true;
  3218. {$ifdef supportbrowser}
  3219. if ((current_module.flags and uf_local_browser)<>0) and
  3220. assigned(localst) and
  3221. locals then
  3222. begin
  3223. pdo:=_class;
  3224. if (owner.symtabletype<>localsymtable) then
  3225. while assigned(pdo) do
  3226. begin
  3227. if pdo.symtable<>aktrecordsymtable then
  3228. begin
  3229. pdo.symtable.moduleid:=local_symtable_index;
  3230. inc(local_symtable_index);
  3231. end;
  3232. pdo:=pdo.childof;
  3233. end;
  3234. parast.moduleid:=local_symtable_index;
  3235. inc(local_symtable_index);
  3236. localst.moduleid:=local_symtable_index;
  3237. inc(local_symtable_index);
  3238. tstoredsymtable(parast).write_references(ppufile,locals);
  3239. tstoredsymtable(localst).write_references(ppufile,locals);
  3240. { decrement for }
  3241. local_symtable_index:=local_symtable_index-2;
  3242. pdo:=_class;
  3243. if (owner.symtabletype<>localsymtable) then
  3244. while assigned(pdo) do
  3245. begin
  3246. if pdo.symtable<>aktrecordsymtable then
  3247. dec(local_symtable_index);
  3248. pdo:=pdo.childof;
  3249. end;
  3250. end;
  3251. {$endif supportbrowser}
  3252. aktparasymtable:=oldparasymtable;
  3253. aktlocalsymtable:=oldlocalsymtable;
  3254. end;
  3255. procedure tprocdef.buildderef;
  3256. var
  3257. oldparasymtable,
  3258. oldlocalsymtable : tsymtable;
  3259. begin
  3260. oldparasymtable:=aktparasymtable;
  3261. oldlocalsymtable:=aktlocalsymtable;
  3262. aktparasymtable:=parast;
  3263. aktlocalsymtable:=localst;
  3264. inherited buildderef;
  3265. _classderef.build(_class);
  3266. { procsym that originaly defined this definition, should be in the
  3267. same symtable }
  3268. procsymderef.build(procsym);
  3269. {$ifdef powerpc}
  3270. { library symbol for AmigaOS/MorphOS }
  3271. libsymderef.build(libsym);
  3272. {$endif powerpc}
  3273. aktparasymtable:=oldparasymtable;
  3274. aktlocalsymtable:=oldlocalsymtable;
  3275. end;
  3276. procedure tprocdef.buildderefimpl;
  3277. var
  3278. oldparasymtable,
  3279. oldlocalsymtable : tsymtable;
  3280. begin
  3281. { released procdef? }
  3282. if not assigned(parast) then
  3283. exit;
  3284. oldparasymtable:=aktparasymtable;
  3285. oldlocalsymtable:=aktlocalsymtable;
  3286. aktparasymtable:=parast;
  3287. aktlocalsymtable:=localst;
  3288. inherited buildderefimpl;
  3289. { Locals, always build deref info it might be needed
  3290. if the unit needs to be reloaded }
  3291. if assigned(localst) then
  3292. begin
  3293. tlocalsymtable(localst).buildderef;
  3294. tlocalsymtable(localst).buildderefimpl;
  3295. end;
  3296. { inline tree }
  3297. if (po_has_inlininginfo in procoptions) then
  3298. begin
  3299. funcretsymderef.build(funcretsym);
  3300. inlininginfo^.code.buildderefimpl;
  3301. end;
  3302. aktparasymtable:=oldparasymtable;
  3303. aktlocalsymtable:=oldlocalsymtable;
  3304. end;
  3305. procedure tprocdef.deref;
  3306. var
  3307. oldparasymtable,
  3308. oldlocalsymtable : tsymtable;
  3309. begin
  3310. { released procdef? }
  3311. if not assigned(parast) then
  3312. exit;
  3313. oldparasymtable:=aktparasymtable;
  3314. oldlocalsymtable:=aktlocalsymtable;
  3315. aktparasymtable:=parast;
  3316. aktlocalsymtable:=localst;
  3317. inherited deref;
  3318. _class:=tobjectdef(_classderef.resolve);
  3319. { procsym that originaly defined this definition, should be in the
  3320. same symtable }
  3321. procsym:=tprocsym(procsymderef.resolve);
  3322. {$ifdef powerpc}
  3323. { library symbol for AmigaOS/MorphOS }
  3324. libsym:=tsym(libsymderef.resolve);
  3325. {$endif powerpc}
  3326. aktparasymtable:=oldparasymtable;
  3327. aktlocalsymtable:=oldlocalsymtable;
  3328. end;
  3329. procedure tprocdef.derefimpl;
  3330. var
  3331. oldparasymtable,
  3332. oldlocalsymtable : tsymtable;
  3333. begin
  3334. oldparasymtable:=aktparasymtable;
  3335. oldlocalsymtable:=aktlocalsymtable;
  3336. aktparasymtable:=parast;
  3337. aktlocalsymtable:=localst;
  3338. { Enable has_inlininginfo when the inlininginfo
  3339. structure is available. The has_inlininginfo was disabled
  3340. after the load, since the data was invalid }
  3341. if assigned(inlininginfo) then
  3342. include(procoptions,po_has_inlininginfo);
  3343. { Locals }
  3344. if assigned(localst) then
  3345. begin
  3346. tlocalsymtable(localst).deref;
  3347. tlocalsymtable(localst).derefimpl;
  3348. end;
  3349. { Inline }
  3350. if (po_has_inlininginfo in procoptions) then
  3351. begin
  3352. inlininginfo^.code.derefimpl;
  3353. { funcretsym, this is always located in the localst }
  3354. funcretsym:=tsym(funcretsymderef.resolve);
  3355. end
  3356. else
  3357. begin
  3358. { safety }
  3359. funcretsym:=nil;
  3360. end;
  3361. aktparasymtable:=oldparasymtable;
  3362. aktlocalsymtable:=oldlocalsymtable;
  3363. end;
  3364. function tprocdef.GetTypeName : string;
  3365. begin
  3366. GetTypeName := FullProcName(false);
  3367. end;
  3368. function tprocdef.mangledname : string;
  3369. var
  3370. hp : TParavarsym;
  3371. hs : string;
  3372. crc : dword;
  3373. newlen,
  3374. oldlen,
  3375. i : integer;
  3376. begin
  3377. if assigned(_mangledname) then
  3378. begin
  3379. {$ifdef compress}
  3380. mangledname:=minilzw_decode(_mangledname^);
  3381. {$else}
  3382. mangledname:=_mangledname^;
  3383. {$endif}
  3384. exit;
  3385. end;
  3386. { we need to use the symtable where the procsym is inserted,
  3387. because that is visible to the world }
  3388. mangledname:=make_mangledname('',procsym.owner,procsym.name);
  3389. oldlen:=length(mangledname);
  3390. { add parameter types }
  3391. for i:=0 to paras.count-1 do
  3392. begin
  3393. hp:=tparavarsym(paras[i]);
  3394. if not(vo_is_hidden_para in hp.varoptions) then
  3395. mangledname:=mangledname+'$'+hp.vardef.mangledparaname;
  3396. end;
  3397. { add resultdef, add $$ as separator to make it unique from a
  3398. parameter separator }
  3399. if not is_void(returndef) then
  3400. mangledname:=mangledname+'$$'+returndef.mangledparaname;
  3401. newlen:=length(mangledname);
  3402. { Replace with CRC if the parameter line is very long }
  3403. if (newlen-oldlen>12) and
  3404. ((newlen>128) or (newlen-oldlen>64)) then
  3405. begin
  3406. crc:=$ffffffff;
  3407. for i:=0 to paras.count-1 do
  3408. begin
  3409. hp:=tparavarsym(paras[i]);
  3410. if not(vo_is_hidden_para in hp.varoptions) then
  3411. begin
  3412. hs:=hp.vardef.mangledparaname;
  3413. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3414. end;
  3415. end;
  3416. hs:=hp.vardef.mangledparaname;
  3417. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3418. mangledname:=Copy(mangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  3419. end;
  3420. {$ifdef compress}
  3421. _mangledname:=stringdup(minilzw_encode(mangledname));
  3422. {$else}
  3423. _mangledname:=stringdup(mangledname);
  3424. {$endif}
  3425. end;
  3426. function tprocdef.cplusplusmangledname : string;
  3427. function getcppparaname(p : tdef) : string;
  3428. const
  3429. ordtype2str : array[tbasetype] of string[2] = (
  3430. '',
  3431. 'Uc','Us','Ui','Us',
  3432. 'Sc','s','i','x',
  3433. 'b','b','b','b',
  3434. 'c','w','x');
  3435. var
  3436. s : string;
  3437. begin
  3438. case p.deftype of
  3439. orddef:
  3440. s:=ordtype2str[torddef(p).typ];
  3441. pointerdef:
  3442. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  3443. else
  3444. internalerror(2103001);
  3445. end;
  3446. getcppparaname:=s;
  3447. end;
  3448. var
  3449. s,s2 : string;
  3450. hp : TParavarsym;
  3451. i : integer;
  3452. begin
  3453. s := procsym.realname;
  3454. if procsym.owner.symtabletype=objectsymtable then
  3455. begin
  3456. s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
  3457. case proctypeoption of
  3458. potype_destructor:
  3459. s:='_$_'+tostr(length(s2))+s2;
  3460. potype_constructor:
  3461. s:='___'+tostr(length(s2))+s2;
  3462. else
  3463. s:='_'+s+'__'+tostr(length(s2))+s2;
  3464. end;
  3465. end
  3466. else s:=s+'__';
  3467. s:=s+'F';
  3468. { concat modifiers }
  3469. { !!!!! }
  3470. { now we handle the parameters }
  3471. if maxparacount>0 then
  3472. begin
  3473. for i:=0 to paras.count-1 do
  3474. begin
  3475. hp:=tparavarsym(paras[i]);
  3476. s2:=getcppparaname(hp.vardef);
  3477. if hp.varspez in [vs_var,vs_out] then
  3478. s2:='R'+s2;
  3479. s:=s+s2;
  3480. end;
  3481. end
  3482. else
  3483. s:=s+'v';
  3484. cplusplusmangledname:=s;
  3485. end;
  3486. procedure tprocdef.setmangledname(const s : string);
  3487. begin
  3488. { This is not allowed anymore, the forward declaration
  3489. already needs to create the correct mangledname, no changes
  3490. afterwards are allowed (PFV) }
  3491. { Exception: interface definitions in mode macpas, since in that }
  3492. { case no reference to the old name can exist yet (JM) }
  3493. if assigned(_mangledname) then
  3494. if ((m_mac in current_settings.modeswitches) and
  3495. (interfacedef)) then
  3496. stringdispose(_mangledname)
  3497. else
  3498. internalerror(200411171);
  3499. {$ifdef compress}
  3500. _mangledname:=stringdup(minilzw_encode(s));
  3501. {$else}
  3502. _mangledname:=stringdup(s);
  3503. {$endif}
  3504. include(procoptions,po_has_mangledname);
  3505. end;
  3506. {***************************************************************************
  3507. TPROCVARDEF
  3508. ***************************************************************************}
  3509. constructor tprocvardef.create(level:byte);
  3510. begin
  3511. inherited create(procvardef,level);
  3512. end;
  3513. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  3514. begin
  3515. inherited ppuload(procvardef,ppufile);
  3516. { load para symtable }
  3517. parast:=tparasymtable.create(unknown_level);
  3518. tparasymtable(parast).ppuload(ppufile);
  3519. parast.defowner:=self;
  3520. end;
  3521. function tprocvardef.getcopy : tstoreddef;
  3522. begin
  3523. result:=self;
  3524. (*
  3525. { saves a definition to the return type }
  3526. returndef : ttype;
  3527. parast : tsymtable;
  3528. paras : tparalist;
  3529. proctypeoption : tproctypeoption;
  3530. proccalloption : tproccalloption;
  3531. procoptions : tprocoptions;
  3532. requiredargarea : aint;
  3533. { number of user visibile parameters }
  3534. maxparacount,
  3535. minparacount : byte;
  3536. {$ifdef i386}
  3537. fpu_used : longint; { how many stack fpu must be empty }
  3538. {$endif i386}
  3539. funcretloc : array[tcallercallee] of TLocation;
  3540. has_paraloc_info : boolean; { paraloc info is available }
  3541. tprocvardef = class(tabstractprocdef)
  3542. constructor create(level:byte);
  3543. constructor ppuload(ppufile:tcompilerppufile);
  3544. function getcopy : tstoreddef;override;
  3545. *)
  3546. end;
  3547. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  3548. var
  3549. oldparasymtable,
  3550. oldlocalsymtable : tsymtable;
  3551. begin
  3552. oldparasymtable:=aktparasymtable;
  3553. oldlocalsymtable:=aktlocalsymtable;
  3554. aktparasymtable:=parast;
  3555. aktlocalsymtable:=nil;
  3556. { here we cannot get a real good value so just give something }
  3557. { plausible (PM) }
  3558. { a more secure way would be
  3559. to allways store in a temp }
  3560. {$ifdef i386}
  3561. if is_fpu(returndef) then
  3562. fpu_used:={2}maxfpuregs
  3563. else
  3564. fpu_used:=0;
  3565. {$endif i386}
  3566. inherited ppuwrite(ppufile);
  3567. { Write this entry }
  3568. ppufile.writeentry(ibprocvardef);
  3569. { Save the para symtable, this is taken from the interface }
  3570. tparasymtable(parast).ppuwrite(ppufile);
  3571. aktparasymtable:=oldparasymtable;
  3572. aktlocalsymtable:=oldlocalsymtable;
  3573. end;
  3574. procedure tprocvardef.buildderef;
  3575. var
  3576. oldparasymtable,
  3577. oldlocalsymtable : tsymtable;
  3578. begin
  3579. oldparasymtable:=aktparasymtable;
  3580. oldlocalsymtable:=aktlocalsymtable;
  3581. aktparasymtable:=parast;
  3582. aktlocalsymtable:=nil;
  3583. inherited buildderef;
  3584. aktparasymtable:=oldparasymtable;
  3585. aktlocalsymtable:=oldlocalsymtable;
  3586. end;
  3587. procedure tprocvardef.deref;
  3588. var
  3589. oldparasymtable,
  3590. oldlocalsymtable : tsymtable;
  3591. begin
  3592. oldparasymtable:=aktparasymtable;
  3593. oldlocalsymtable:=aktlocalsymtable;
  3594. aktparasymtable:=parast;
  3595. aktlocalsymtable:=nil;
  3596. inherited deref;
  3597. aktparasymtable:=oldparasymtable;
  3598. aktlocalsymtable:=oldlocalsymtable;
  3599. end;
  3600. function tprocvardef.getsymtable(t:tgetsymtable):tsymtable;
  3601. begin
  3602. case t of
  3603. gs_para :
  3604. getsymtable:=parast;
  3605. else
  3606. getsymtable:=nil;
  3607. end;
  3608. end;
  3609. function tprocvardef.size : aint;
  3610. begin
  3611. if (po_methodpointer in procoptions) and
  3612. not(po_addressonly in procoptions) then
  3613. size:=2*sizeof(aint)
  3614. else
  3615. size:=sizeof(aint);
  3616. end;
  3617. function tprocvardef.is_methodpointer:boolean;
  3618. begin
  3619. result:=(po_methodpointer in procoptions);
  3620. end;
  3621. function tprocvardef.is_addressonly:boolean;
  3622. begin
  3623. result:=not(po_methodpointer in procoptions) or
  3624. (po_addressonly in procoptions);
  3625. end;
  3626. function tprocvardef.getmangledparaname:string;
  3627. begin
  3628. result:='procvar';
  3629. end;
  3630. procedure tprocvardef.write_rtti_data(rt:trttitype);
  3631. procedure write_para(parasym:tparavarsym);
  3632. var
  3633. paraspec : byte;
  3634. begin
  3635. { only store user visible parameters }
  3636. if not(vo_is_hidden_para in parasym.varoptions) then
  3637. begin
  3638. case parasym.varspez of
  3639. vs_value: paraspec := 0;
  3640. vs_const: paraspec := pfConst;
  3641. vs_var : paraspec := pfVar;
  3642. vs_out : paraspec := pfOut;
  3643. end;
  3644. { write flags for current parameter }
  3645. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec));
  3646. { write name of current parameter }
  3647. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(parasym.realname)));
  3648. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(parasym.realname));
  3649. { write name of type of current parameter }
  3650. tstoreddef(parasym.vardef).write_rtti_name;
  3651. end;
  3652. end;
  3653. var
  3654. methodkind : byte;
  3655. i : integer;
  3656. begin
  3657. if po_methodpointer in procoptions then
  3658. begin
  3659. { write method id and name }
  3660. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkmethod));
  3661. write_rtti_name;
  3662. {$ifdef cpurequiresproperalignment}
  3663. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  3664. {$endif cpurequiresproperalignment}
  3665. { write kind of method (can only be function or procedure)}
  3666. if returndef = voidtype then
  3667. methodkind := mkProcedure
  3668. else
  3669. methodkind := mkFunction;
  3670. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(methodkind));
  3671. { get # of parameters }
  3672. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(maxparacount));
  3673. { write parameter info. The parameters must be written in reverse order
  3674. if this method uses right to left parameter pushing! }
  3675. if proccalloption in pushleftright_pocalls then
  3676. begin
  3677. for i:=0 to paras.count-1 do
  3678. write_para(tparavarsym(paras[i]));
  3679. end
  3680. else
  3681. begin
  3682. for i:=paras.count-1 downto 0 do
  3683. write_para(tparavarsym(paras[i]));
  3684. end;
  3685. { write name of result type }
  3686. tstoreddef(returndef).write_rtti_name;
  3687. end
  3688. else
  3689. begin
  3690. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkprocvar));
  3691. write_rtti_name;
  3692. end;
  3693. end;
  3694. function tprocvardef.is_publishable : boolean;
  3695. begin
  3696. is_publishable:=(po_methodpointer in procoptions);
  3697. end;
  3698. function tprocvardef.GetTypeName : string;
  3699. var
  3700. s: string;
  3701. showhidden : boolean;
  3702. begin
  3703. {$ifdef EXTDEBUG}
  3704. showhidden:=true;
  3705. {$else EXTDEBUG}
  3706. showhidden:=false;
  3707. {$endif EXTDEBUG}
  3708. s:='<';
  3709. if po_classmethod in procoptions then
  3710. s := s+'class method type of'
  3711. else
  3712. if po_addressonly in procoptions then
  3713. s := s+'address of'
  3714. else
  3715. s := s+'procedure variable type of';
  3716. if po_local in procoptions then
  3717. s := s+' local';
  3718. if assigned(returndef) and
  3719. (returndef<>voidtype) then
  3720. s:=s+' function'+typename_paras(showhidden)+':'+returndef.GetTypeName
  3721. else
  3722. s:=s+' procedure'+typename_paras(showhidden);
  3723. if po_methodpointer in procoptions then
  3724. s := s+' of object';
  3725. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  3726. end;
  3727. {***************************************************************************
  3728. TOBJECTDEF
  3729. ***************************************************************************}
  3730. type
  3731. tproptablelistitem = class(TLinkedListItem)
  3732. index : longint;
  3733. def : tobjectdef;
  3734. end;
  3735. tpropnamelistitem = class(TLinkedListItem)
  3736. index : longint;
  3737. name : stringid;
  3738. owner : tsymtable;
  3739. end;
  3740. var
  3741. proptablelist : tlinkedlist;
  3742. propnamelist : tlinkedlist;
  3743. function searchproptablelist(p : tobjectdef) : tproptablelistitem;
  3744. var
  3745. hp : tproptablelistitem;
  3746. begin
  3747. hp:=tproptablelistitem(proptablelist.first);
  3748. while assigned(hp) do
  3749. if hp.def=p then
  3750. begin
  3751. result:=hp;
  3752. exit;
  3753. end
  3754. else
  3755. hp:=tproptablelistitem(hp.next);
  3756. result:=nil;
  3757. end;
  3758. function searchpropnamelist(const n:string) : tpropnamelistitem;
  3759. var
  3760. hp : tpropnamelistitem;
  3761. begin
  3762. hp:=tpropnamelistitem(propnamelist.first);
  3763. while assigned(hp) do
  3764. if hp.name=n then
  3765. begin
  3766. result:=hp;
  3767. exit;
  3768. end
  3769. else
  3770. hp:=tpropnamelistitem(hp.next);
  3771. result:=nil;
  3772. end;
  3773. constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  3774. begin
  3775. inherited create(objectdef);
  3776. objecttype:=ot;
  3777. objectoptions:=[];
  3778. childof:=nil;
  3779. symtable:=tobjectsymtable.create(n,current_settings.packrecords);
  3780. { create space for vmt !! }
  3781. vmt_offset:=0;
  3782. symtable.defowner:=self;
  3783. lastvtableindex:=0;
  3784. set_parent(c);
  3785. objname:=stringdup(upper(n));
  3786. objrealname:=stringdup(n);
  3787. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  3788. prepareguid;
  3789. { setup implemented interfaces }
  3790. if objecttype in [odt_class,odt_interfacecorba] then
  3791. implementedinterfaces:=timplementedinterfaces.create
  3792. else
  3793. implementedinterfaces:=nil;
  3794. writing_class_record_dbginfo:=false;
  3795. iitype := etStandard;
  3796. end;
  3797. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  3798. var
  3799. i,implintfcount: longint;
  3800. d : tderef;
  3801. begin
  3802. inherited ppuload(objectdef,ppufile);
  3803. objecttype:=tobjectdeftype(ppufile.getbyte);
  3804. objrealname:=stringdup(ppufile.getstring);
  3805. objname:=stringdup(upper(objrealname^));
  3806. symtable:=tobjectsymtable.create(objrealname^,0);
  3807. tobjectsymtable(symtable).datasize:=ppufile.getaint;
  3808. tobjectsymtable(symtable).fieldalignment:=ppufile.getbyte;
  3809. tobjectsymtable(symtable).recordalignment:=ppufile.getbyte;
  3810. vmt_offset:=ppufile.getlongint;
  3811. ppufile.getderef(childofderef);
  3812. ppufile.getsmallset(objectoptions);
  3813. { load guid }
  3814. iidstr:=nil;
  3815. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3816. begin
  3817. new(iidguid);
  3818. ppufile.getguid(iidguid^);
  3819. iidstr:=stringdup(ppufile.getstring);
  3820. lastvtableindex:=ppufile.getlongint;
  3821. end;
  3822. { load implemented interfaces }
  3823. if objecttype in [odt_class,odt_interfacecorba] then
  3824. begin
  3825. implementedinterfaces:=timplementedinterfaces.create;
  3826. implintfcount:=ppufile.getlongint;
  3827. for i:=1 to implintfcount do
  3828. begin
  3829. ppufile.getderef(d);
  3830. implementedinterfaces.addintf_deref(d,ppufile.getlongint);
  3831. end;
  3832. end
  3833. else
  3834. implementedinterfaces:=nil;
  3835. tobjectsymtable(symtable).ppuload(ppufile);
  3836. symtable.defowner:=self;
  3837. { handles the predefined class tobject }
  3838. { the last TOBJECT which is loaded gets }
  3839. { it ! }
  3840. if (childof=nil) and
  3841. (objecttype=odt_class) and
  3842. (objname^='TOBJECT') then
  3843. class_tobject:=self;
  3844. if (childof=nil) and
  3845. (objecttype=odt_interfacecom) and
  3846. (objname^='IUNKNOWN') then
  3847. interface_iunknown:=self;
  3848. writing_class_record_dbginfo:=false;
  3849. end;
  3850. destructor tobjectdef.destroy;
  3851. begin
  3852. if assigned(symtable) then
  3853. symtable.free;
  3854. stringdispose(objname);
  3855. stringdispose(objrealname);
  3856. if assigned(iidstr) then
  3857. stringdispose(iidstr);
  3858. if assigned(implementedinterfaces) then
  3859. implementedinterfaces.free;
  3860. if assigned(iidguid) then
  3861. dispose(iidguid);
  3862. inherited destroy;
  3863. end;
  3864. function tobjectdef.getcopy : tstoreddef;
  3865. var
  3866. i,
  3867. implintfcount : longint;
  3868. begin
  3869. result:=tobjectdef.create(objecttype,objname^,childof);
  3870. tobjectdef(result).symtable:=symtable.getcopy;
  3871. if assigned(objname) then
  3872. tobjectdef(result).objname:=stringdup(objname^);
  3873. if assigned(objrealname) then
  3874. tobjectdef(result).objrealname:=stringdup(objrealname^);
  3875. tobjectdef(result).objectoptions:=objectoptions;
  3876. tobjectdef(result).vmt_offset:=vmt_offset;
  3877. if assigned(iidguid) then
  3878. begin
  3879. new(tobjectdef(result).iidguid);
  3880. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  3881. end;
  3882. if assigned(iidstr) then
  3883. tobjectdef(result).iidstr:=stringdup(iidstr^);
  3884. tobjectdef(result).lastvtableindex:=lastvtableindex;
  3885. if assigned(implementedinterfaces) then
  3886. begin
  3887. implintfcount:=implementedinterfaces.count;
  3888. for i:=1 to implintfcount do
  3889. begin
  3890. tobjectdef(result).implementedinterfaces.addintf_ioffset(implementedinterfaces.interfaces(i),
  3891. implementedinterfaces.ioffsets(i));
  3892. end;
  3893. end;
  3894. end;
  3895. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  3896. var
  3897. implintfcount : longint;
  3898. i : longint;
  3899. begin
  3900. inherited ppuwrite(ppufile);
  3901. ppufile.putbyte(byte(objecttype));
  3902. ppufile.putstring(objrealname^);
  3903. ppufile.putaint(tobjectsymtable(symtable).datasize);
  3904. ppufile.putbyte(tobjectsymtable(symtable).fieldalignment);
  3905. ppufile.putbyte(tobjectsymtable(symtable).recordalignment);
  3906. ppufile.putlongint(vmt_offset);
  3907. ppufile.putderef(childofderef);
  3908. ppufile.putsmallset(objectoptions);
  3909. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3910. begin
  3911. ppufile.putguid(iidguid^);
  3912. ppufile.putstring(iidstr^);
  3913. ppufile.putlongint(lastvtableindex);
  3914. end;
  3915. if objecttype in [odt_class,odt_interfacecorba] then
  3916. begin
  3917. implintfcount:=implementedinterfaces.count;
  3918. ppufile.putlongint(implintfcount);
  3919. for i:=1 to implintfcount do
  3920. begin
  3921. ppufile.putderef(implementedinterfaces.interfacesderef(i));
  3922. ppufile.putlongint(implementedinterfaces.ioffsets(i));
  3923. end;
  3924. end;
  3925. ppufile.writeentry(ibobjectdef);
  3926. tobjectsymtable(symtable).ppuwrite(ppufile);
  3927. end;
  3928. function tobjectdef.GetTypeName:string;
  3929. begin
  3930. if (self <> aktobjectdef) then
  3931. GetTypeName:=typename
  3932. else
  3933. { in this case we will go in endless recursion, because then }
  3934. { there is no tsym associated yet with the def. It can occur }
  3935. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  3936. { instead of the actual type name }
  3937. GetTypeName:='<Currently Parsed Class>';
  3938. end;
  3939. procedure tobjectdef.buildderef;
  3940. var
  3941. oldrecsyms : tsymtable;
  3942. begin
  3943. inherited buildderef;
  3944. childofderef.build(childof);
  3945. oldrecsyms:=aktrecordsymtable;
  3946. aktrecordsymtable:=symtable;
  3947. tstoredsymtable(symtable).buildderef;
  3948. aktrecordsymtable:=oldrecsyms;
  3949. if objecttype in [odt_class,odt_interfacecorba] then
  3950. implementedinterfaces.buildderef;
  3951. end;
  3952. procedure tobjectdef.deref;
  3953. var
  3954. oldrecsyms : tsymtable;
  3955. begin
  3956. inherited deref;
  3957. childof:=tobjectdef(childofderef.resolve);
  3958. oldrecsyms:=aktrecordsymtable;
  3959. aktrecordsymtable:=symtable;
  3960. tstoredsymtable(symtable).deref;
  3961. aktrecordsymtable:=oldrecsyms;
  3962. if objecttype in [odt_class,odt_interfacecorba] then
  3963. implementedinterfaces.deref;
  3964. end;
  3965. function tobjectdef.getparentdef:tdef;
  3966. begin
  3967. {$warning TODO Remove getparentdef hack}
  3968. { With 2 forward declared classes with the child class before the
  3969. parent class the child class is written earlier to the ppu. Leaving it
  3970. possible to have a reference to the parent class for property overriding,
  3971. but the parent class still has the childof not resolved yet (PFV) }
  3972. if childof=nil then
  3973. childof:=tobjectdef(childofderef.resolve);
  3974. result:=childof;
  3975. end;
  3976. procedure tobjectdef.prepareguid;
  3977. begin
  3978. { set up guid }
  3979. if not assigned(iidguid) then
  3980. begin
  3981. new(iidguid);
  3982. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  3983. end;
  3984. { setup iidstring }
  3985. if not assigned(iidstr) then
  3986. iidstr:=stringdup(''); { default is empty string }
  3987. end;
  3988. procedure tobjectdef.set_parent( c : tobjectdef);
  3989. begin
  3990. { nothing to do if the parent was not forward !}
  3991. if assigned(childof) then
  3992. exit;
  3993. childof:=c;
  3994. { some options are inherited !! }
  3995. if assigned(c) then
  3996. begin
  3997. { only important for classes }
  3998. lastvtableindex:=c.lastvtableindex;
  3999. objectoptions:=objectoptions+(c.objectoptions*
  4000. inherited_objectoptions);
  4001. if not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then
  4002. begin
  4003. { add the data of the anchestor class }
  4004. inc(tobjectsymtable(symtable).datasize,tobjectsymtable(c.symtable).datasize);
  4005. if (oo_has_vmt in objectoptions) and
  4006. (oo_has_vmt in c.objectoptions) then
  4007. dec(tobjectsymtable(symtable).datasize,sizeof(aint));
  4008. { if parent has a vmt field then
  4009. the offset is the same for the child PM }
  4010. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  4011. begin
  4012. vmt_offset:=c.vmt_offset;
  4013. include(objectoptions,oo_has_vmt);
  4014. end;
  4015. end;
  4016. end;
  4017. end;
  4018. procedure tobjectdef.insertvmt;
  4019. begin
  4020. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4021. exit;
  4022. if (oo_has_vmt in objectoptions) then
  4023. internalerror(12345)
  4024. else
  4025. begin
  4026. tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,
  4027. tobjectsymtable(symtable).fieldalignment);
  4028. {$ifdef cpurequiresproperalignment}
  4029. tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,sizeof(aint));
  4030. {$endif cpurequiresproperalignment}
  4031. vmt_offset:=tobjectsymtable(symtable).datasize;
  4032. inc(tobjectsymtable(symtable).datasize,sizeof(aint));
  4033. include(objectoptions,oo_has_vmt);
  4034. end;
  4035. end;
  4036. procedure tobjectdef.check_forwards;
  4037. begin
  4038. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then
  4039. tstoredsymtable(symtable).check_forwards;
  4040. if (oo_is_forward in objectoptions) then
  4041. begin
  4042. { ok, in future, the forward can be resolved }
  4043. Message1(sym_e_class_forward_not_resolved,objrealname^);
  4044. exclude(objectoptions,oo_is_forward);
  4045. end;
  4046. end;
  4047. { true, if self inherits from d (or if they are equal) }
  4048. function tobjectdef.is_related(d : tdef) : boolean;
  4049. var
  4050. hp : tobjectdef;
  4051. begin
  4052. hp:=self;
  4053. while assigned(hp) do
  4054. begin
  4055. if hp=d then
  4056. begin
  4057. is_related:=true;
  4058. exit;
  4059. end;
  4060. hp:=hp.childof;
  4061. end;
  4062. is_related:=false;
  4063. end;
  4064. procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer);
  4065. begin
  4066. { if we found already a destructor, then we exit }
  4067. if (ppointer(sd)^=nil) and
  4068. (Tsym(sym).typ=procsym) then
  4069. ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor);
  4070. end;
  4071. function tobjectdef.searchdestructor : tprocdef;
  4072. var
  4073. o : tobjectdef;
  4074. sd : tprocdef;
  4075. begin
  4076. searchdestructor:=nil;
  4077. o:=self;
  4078. sd:=nil;
  4079. while assigned(o) do
  4080. begin
  4081. o.symtable.foreach_static(@_searchdestructor,@sd);
  4082. if assigned(sd) then
  4083. begin
  4084. searchdestructor:=sd;
  4085. exit;
  4086. end;
  4087. o:=o.childof;
  4088. end;
  4089. end;
  4090. function tobjectdef.size : aint;
  4091. begin
  4092. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4093. result:=sizeof(aint)
  4094. else
  4095. result:=tobjectsymtable(symtable).datasize;
  4096. end;
  4097. function tobjectdef.alignment:shortint;
  4098. begin
  4099. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4100. alignment:=sizeof(aint)
  4101. else
  4102. alignment:=tobjectsymtable(symtable).recordalignment;
  4103. end;
  4104. function tobjectdef.vmtmethodoffset(index:longint):longint;
  4105. begin
  4106. { for offset of methods for classes, see rtl/inc/objpash.inc }
  4107. case objecttype of
  4108. odt_class:
  4109. { the +2*sizeof(Aint) is size and -size }
  4110. vmtmethodoffset:=(index+10)*sizeof(aint)+2*sizeof(AInt);
  4111. odt_interfacecom,odt_interfacecorba:
  4112. vmtmethodoffset:=index*sizeof(aint);
  4113. else
  4114. {$ifdef WITHDMT}
  4115. vmtmethodoffset:=(index+4)*sizeof(aint);
  4116. {$else WITHDMT}
  4117. vmtmethodoffset:=(index+3)*sizeof(aint);
  4118. {$endif WITHDMT}
  4119. end;
  4120. end;
  4121. function tobjectdef.vmt_mangledname : string;
  4122. begin
  4123. if not(oo_has_vmt in objectoptions) then
  4124. Message1(parser_n_object_has_no_vmt,objrealname^);
  4125. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  4126. end;
  4127. function tobjectdef.rtti_name : string;
  4128. begin
  4129. rtti_name:=make_mangledname('RTTI',owner,objname^);
  4130. end;
  4131. function tobjectdef.needs_inittable : boolean;
  4132. begin
  4133. case objecttype of
  4134. odt_dispinterface,
  4135. odt_class :
  4136. needs_inittable:=false;
  4137. odt_interfacecom:
  4138. needs_inittable:=true;
  4139. odt_interfacecorba:
  4140. needs_inittable:=is_related(interface_iunknown);
  4141. odt_object:
  4142. needs_inittable:=tobjectsymtable(symtable).needs_init_final;
  4143. else
  4144. internalerror(200108267);
  4145. end;
  4146. end;
  4147. function tobjectdef.members_need_inittable : boolean;
  4148. begin
  4149. members_need_inittable:=tobjectsymtable(symtable).needs_init_final;
  4150. end;
  4151. procedure tobjectdef.collect_published_properties(sym:tnamedindexitem;arg:pointer);
  4152. var
  4153. hp : tpropnamelistitem;
  4154. begin
  4155. if (tsym(sym).typ=propertysym) and
  4156. (sp_published in tsym(sym).symoptions) then
  4157. begin
  4158. hp:=searchpropnamelist(tsym(sym).name);
  4159. if not(assigned(hp)) then
  4160. begin
  4161. hp:=tpropnamelistitem.create;
  4162. hp.name:=tsym(sym).name;
  4163. hp.index:=propnamelist.count;
  4164. hp.owner:=tsym(sym).owner;
  4165. propnamelist.concat(hp);
  4166. end;
  4167. end;
  4168. end;
  4169. procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
  4170. begin
  4171. if (tsym(sym).typ=propertysym) and
  4172. (sp_published in tsym(sym).symoptions) then
  4173. inc(plongint(arg)^);
  4174. end;
  4175. procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
  4176. var
  4177. proctypesinfo : byte;
  4178. propnameitem : tpropnamelistitem;
  4179. procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
  4180. var
  4181. typvalue : byte;
  4182. hp : ppropaccesslistitem;
  4183. address : longint;
  4184. def : tdef;
  4185. hpropsym : tpropertysym;
  4186. propaccesslist : tpropaccesslist;
  4187. begin
  4188. hpropsym:=tpropertysym(sym);
  4189. repeat
  4190. propaccesslist:=hpropsym.propaccesslist[pap];
  4191. if not propaccesslist.empty then
  4192. break;
  4193. hpropsym:=hpropsym.overridenpropsym;
  4194. until not assigned(hpropsym);
  4195. if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then
  4196. begin
  4197. current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,unsetvalue));
  4198. typvalue:=3;
  4199. end
  4200. else if propaccesslist.firstsym^.sym.typ=fieldvarsym then
  4201. begin
  4202. address:=0;
  4203. hp:=propaccesslist.firstsym;
  4204. def:=nil;
  4205. while assigned(hp) do
  4206. begin
  4207. case hp^.sltype of
  4208. sl_load :
  4209. begin
  4210. def:=tfieldvarsym(hp^.sym).vardef;
  4211. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  4212. end;
  4213. sl_subscript :
  4214. begin
  4215. if not(assigned(def) and (def.deftype=recorddef)) then
  4216. internalerror(200402171);
  4217. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  4218. def:=tfieldvarsym(hp^.sym).vardef;
  4219. end;
  4220. sl_vec :
  4221. begin
  4222. if not(assigned(def) and (def.deftype=arraydef)) then
  4223. internalerror(200402172);
  4224. def:=tarraydef(def).elementdef;
  4225. inc(address,def.size*hp^.value);
  4226. end;
  4227. end;
  4228. hp:=hp^.next;
  4229. end;
  4230. current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,address));
  4231. typvalue:=0;
  4232. end
  4233. else
  4234. begin
  4235. { When there was an error then procdef is not assigned }
  4236. if not assigned(propaccesslist.procdef) then
  4237. exit;
  4238. if not(po_virtualmethod in tprocdef(propaccesslist.procdef).procoptions) then
  4239. begin
  4240. current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(tprocdef(propaccesslist.procdef).mangledname,0));
  4241. typvalue:=1;
  4242. end
  4243. else
  4244. begin
  4245. { virtual method, write vmt offset }
  4246. current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,
  4247. tprocdef(propaccesslist.procdef)._class.vmtmethodoffset(tprocdef(propaccesslist.procdef).extnumber)));
  4248. typvalue:=2;
  4249. end;
  4250. end;
  4251. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  4252. end;
  4253. begin
  4254. if (tsym(sym).typ=propertysym) and
  4255. (sp_published in tsym(sym).symoptions) then
  4256. begin
  4257. if ppo_indexed in tpropertysym(sym).propoptions then
  4258. proctypesinfo:=$40
  4259. else
  4260. proctypesinfo:=0;
  4261. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(tpropertysym(sym).propdef).get_rtti_label(fullrtti)));
  4262. writeaccessproc(palt_read,0,0);
  4263. writeaccessproc(palt_write,2,0);
  4264. { is it stored ? }
  4265. if not(ppo_stored in tpropertysym(sym).propoptions) then
  4266. begin
  4267. { no, so put a constant zero }
  4268. current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,0));
  4269. proctypesinfo:=proctypesinfo or (3 shl 4);
  4270. end
  4271. else
  4272. writeaccessproc(palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
  4273. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).index));
  4274. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).default));
  4275. propnameitem:=searchpropnamelist(tpropertysym(sym).name);
  4276. if not assigned(propnameitem) then
  4277. internalerror(200512201);
  4278. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.index));
  4279. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
  4280. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
  4281. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tpropertysym(sym).realname));
  4282. {$ifdef cpurequiresproperalignment}
  4283. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4284. {$endif cpurequiresproperalignment}
  4285. end;
  4286. end;
  4287. procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  4288. begin
  4289. if needs_prop_entry(tsym(sym)) then
  4290. begin
  4291. case tsym(sym).typ of
  4292. propertysym:
  4293. tstoreddef(tpropertysym(sym).propdef).get_rtti_label(fullrtti);
  4294. fieldvarsym:
  4295. tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(fullrtti);
  4296. else
  4297. internalerror(1509991);
  4298. end;
  4299. end;
  4300. end;
  4301. procedure tobjectdef.write_child_rtti_data(rt:trttitype);
  4302. begin
  4303. FRTTIType:=rt;
  4304. case rt of
  4305. initrtti :
  4306. symtable.foreach(@generate_field_rtti,nil);
  4307. fullrtti :
  4308. symtable.foreach(@generate_published_child_rtti,nil);
  4309. else
  4310. internalerror(200108301);
  4311. end;
  4312. end;
  4313. procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
  4314. var
  4315. hp : tproptablelistitem;
  4316. begin
  4317. if (tsym(sym).typ=fieldvarsym) and
  4318. (sp_published in tsym(sym).symoptions) then
  4319. begin
  4320. if tfieldvarsym(sym).vardef.deftype<>objectdef then
  4321. internalerror(0206001);
  4322. hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vardef));
  4323. if not(assigned(hp)) then
  4324. begin
  4325. hp:=tproptablelistitem.create;
  4326. hp.def:=tobjectdef(tfieldvarsym(sym).vardef);
  4327. hp.index:=proptablelist.count+1;
  4328. proptablelist.concat(hp);
  4329. end;
  4330. inc(plongint(arg)^);
  4331. end;
  4332. end;
  4333. procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
  4334. var
  4335. hp : tproptablelistitem;
  4336. begin
  4337. if needs_prop_entry(tsym(sym)) and
  4338. (tsym(sym).typ=fieldvarsym) then
  4339. begin
  4340. {$ifdef cpurequiresproperalignment}
  4341. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(AInt)));
  4342. {$endif cpurequiresproperalignment}
  4343. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset));
  4344. hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vardef));
  4345. if not(assigned(hp)) then
  4346. internalerror(0206002);
  4347. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(hp.index));
  4348. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname)));
  4349. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tfieldvarsym(sym).realname));
  4350. end;
  4351. end;
  4352. function tobjectdef.generate_field_table : tasmlabel;
  4353. var
  4354. fieldtable,
  4355. classtable : tasmlabel;
  4356. hp : tproptablelistitem;
  4357. fieldcount : longint;
  4358. begin
  4359. proptablelist:=TLinkedList.Create;
  4360. current_asmdata.getdatalabel(fieldtable);
  4361. current_asmdata.getdatalabel(classtable);
  4362. maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
  4363. new_section(current_asmdata.asmlists[al_rtti],sec_rodata,classtable.name,const_align(sizeof(aint)));
  4364. { fields }
  4365. fieldcount:=0;
  4366. symtable.foreach(@count_published_fields,@fieldcount);
  4367. current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(fieldtable));
  4368. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(fieldcount));
  4369. {$ifdef cpurequiresproperalignment}
  4370. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4371. {$endif cpurequiresproperalignment}
  4372. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(classtable));
  4373. symtable.foreach(@writefields,nil);
  4374. { generate the class table }
  4375. current_asmdata.asmlists[al_rtti].concat(tai_align.create(const_align(sizeof(aint))));
  4376. current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(classtable));
  4377. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(proptablelist.count));
  4378. {$ifdef cpurequiresproperalignment}
  4379. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4380. {$endif cpurequiresproperalignment}
  4381. hp:=tproptablelistitem(proptablelist.first);
  4382. while assigned(hp) do
  4383. begin
  4384. current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tobjectdef(hp.def).vmt_mangledname,0));
  4385. hp:=tproptablelistitem(hp.next);
  4386. end;
  4387. generate_field_table:=fieldtable;
  4388. proptablelist.free;
  4389. proptablelist:=nil;
  4390. end;
  4391. procedure tobjectdef.write_rtti_data(rt:trttitype);
  4392. procedure collect_unique_published_props(pd:tobjectdef);
  4393. begin
  4394. if assigned(pd.childof) then
  4395. collect_unique_published_props(pd.childof);
  4396. pd.symtable.foreach(@collect_published_properties,nil);
  4397. end;
  4398. var
  4399. i : longint;
  4400. propcount : longint;
  4401. begin
  4402. case objecttype of
  4403. odt_class:
  4404. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkclass));
  4405. odt_object:
  4406. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkobject));
  4407. odt_interfacecom:
  4408. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkinterface));
  4409. odt_interfacecorba:
  4410. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkinterfaceCorba));
  4411. else
  4412. exit;
  4413. end;
  4414. { generate the name }
  4415. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(objrealname^)));
  4416. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(objrealname^));
  4417. {$ifdef cpurequiresproperalignment}
  4418. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4419. {$endif cpurequiresproperalignment}
  4420. case rt of
  4421. initrtti :
  4422. begin
  4423. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(size));
  4424. if objecttype in [odt_class,odt_object] then
  4425. begin
  4426. count:=0;
  4427. FRTTIType:=rt;
  4428. symtable.foreach(@count_field_rtti,nil);
  4429. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(count));
  4430. symtable.foreach(@write_field_rtti,nil);
  4431. end;
  4432. end;
  4433. fullrtti :
  4434. begin
  4435. { Collect unique property names with nameindex }
  4436. propnamelist:=TLinkedList.Create;
  4437. collect_unique_published_props(self);
  4438. if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4439. begin
  4440. if (oo_has_vmt in objectoptions) then
  4441. current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(vmt_mangledname,0))
  4442. else
  4443. current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
  4444. end;
  4445. { write parent typeinfo }
  4446. if assigned(childof) and ((oo_can_have_published in childof.objectoptions) or
  4447. (objecttype in [odt_interfacecom,odt_interfacecorba])) then
  4448. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(childof.get_rtti_label(fullrtti)))
  4449. else
  4450. current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
  4451. if objecttype in [odt_object,odt_class] then
  4452. begin
  4453. { total number of unique properties }
  4454. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
  4455. end
  4456. else
  4457. { interface: write flags, iid and iidstr }
  4458. begin
  4459. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(
  4460. { ugly, but working }
  4461. longint([
  4462. TCompilerIntfFlag(ord(ifHasGuid)*ord(assigned(iidguid))),
  4463. TCompilerIntfFlag(ord(ifHasStrGUID)*ord(assigned(iidstr)))
  4464. ])
  4465. {
  4466. ifDispInterface,
  4467. ifDispatch, }
  4468. ));
  4469. {$ifdef cpurequiresproperalignment}
  4470. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4471. {$endif cpurequiresproperalignment}
  4472. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(iidguid^.D1)));
  4473. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(iidguid^.D2));
  4474. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(iidguid^.D3));
  4475. for i:=Low(iidguid^.D4) to High(iidguid^.D4) do
  4476. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(iidguid^.D4[i]));
  4477. end;
  4478. { write unit name }
  4479. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
  4480. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(current_module.realmodulename^));
  4481. {$ifdef cpurequiresproperalignment}
  4482. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4483. {$endif cpurequiresproperalignment}
  4484. { write iidstr }
  4485. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  4486. begin
  4487. if assigned(iidstr) then
  4488. begin
  4489. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(iidstr^)));
  4490. current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(iidstr^));
  4491. end
  4492. else
  4493. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
  4494. {$ifdef cpurequiresproperalignment}
  4495. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4496. {$endif cpurequiresproperalignment}
  4497. end;
  4498. { write published properties for this object }
  4499. if objecttype in [odt_object,odt_class] then
  4500. begin
  4501. propcount:=0;
  4502. symtable.foreach(@count_published_properties,@propcount);
  4503. current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propcount));
  4504. {$ifdef cpurequiresproperalignment}
  4505. current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
  4506. {$endif cpurequiresproperalignment}
  4507. end;
  4508. symtable.foreach(@write_property_info,nil);
  4509. propnamelist.free;
  4510. propnamelist:=nil;
  4511. end;
  4512. end;
  4513. end;
  4514. function tobjectdef.is_publishable : boolean;
  4515. begin
  4516. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
  4517. end;
  4518. {****************************************************************************
  4519. TIMPLEMENTEDINTERFACES
  4520. ****************************************************************************}
  4521. type
  4522. tnamemap = class(TNamedIndexItem)
  4523. listnext : TNamedIndexItem;
  4524. newname: pshortstring;
  4525. constructor create(const aname, anewname: string);
  4526. destructor destroy; override;
  4527. end;
  4528. constructor tnamemap.create(const aname, anewname: string);
  4529. begin
  4530. inherited createname(aname);
  4531. newname:=stringdup(anewname);
  4532. end;
  4533. destructor tnamemap.destroy;
  4534. begin
  4535. stringdispose(newname);
  4536. inherited destroy;
  4537. end;
  4538. type
  4539. tprocdefstore = class(TNamedIndexItem)
  4540. procdef: tprocdef;
  4541. constructor create(aprocdef: tprocdef);
  4542. end;
  4543. constructor tprocdefstore.create(aprocdef: tprocdef);
  4544. begin
  4545. inherited create;
  4546. procdef:=aprocdef;
  4547. end;
  4548. constructor timplintfentry.create(aintf: tobjectdef);
  4549. begin
  4550. inherited create;
  4551. intf:=aintf;
  4552. ioffset:=-1;
  4553. namemappings:=nil;
  4554. procdefs:=nil;
  4555. end;
  4556. constructor timplintfentry.create_deref(d:tderef);
  4557. begin
  4558. inherited create;
  4559. intf:=nil;
  4560. intfderef:=d;
  4561. ioffset:=-1;
  4562. namemappings:=nil;
  4563. procdefs:=nil;
  4564. end;
  4565. destructor timplintfentry.destroy;
  4566. begin
  4567. if assigned(namemappings) then
  4568. namemappings.free;
  4569. if assigned(procdefs) then
  4570. procdefs.free;
  4571. inherited destroy;
  4572. end;
  4573. constructor timplementedinterfaces.create;
  4574. begin
  4575. finterfaces:=tindexarray.create(1);
  4576. end;
  4577. destructor timplementedinterfaces.destroy;
  4578. begin
  4579. finterfaces.destroy;
  4580. end;
  4581. function timplementedinterfaces.count: longint;
  4582. begin
  4583. count:=finterfaces.count;
  4584. end;
  4585. procedure timplementedinterfaces.checkindex(intfindex: longint);
  4586. begin
  4587. if (intfindex<1) or (intfindex>count) then
  4588. InternalError(200006123);
  4589. end;
  4590. function timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
  4591. begin
  4592. checkindex(intfindex);
  4593. interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
  4594. end;
  4595. function timplementedinterfaces.interfacesderef(intfindex: longint): tderef;
  4596. begin
  4597. checkindex(intfindex);
  4598. interfacesderef:=timplintfentry(finterfaces.search(intfindex)).intfderef;
  4599. end;
  4600. function timplementedinterfaces.ioffsets(intfindex: longint): longint;
  4601. begin
  4602. checkindex(intfindex);
  4603. ioffsets:=timplintfentry(finterfaces.search(intfindex)).ioffset;
  4604. end;
  4605. procedure timplementedinterfaces.setioffsets(intfindex,iofs:longint);
  4606. begin
  4607. checkindex(intfindex);
  4608. timplintfentry(finterfaces.search(intfindex)).ioffset:=iofs;
  4609. end;
  4610. function timplementedinterfaces.implindex(intfindex:longint):longint;
  4611. begin
  4612. checkindex(intfindex);
  4613. result:=timplintfentry(finterfaces.search(intfindex)).implindex;
  4614. end;
  4615. procedure timplementedinterfaces.setimplindex(intfindex,implidx:longint);
  4616. begin
  4617. checkindex(intfindex);
  4618. timplintfentry(finterfaces.search(intfindex)).implindex:=implidx;
  4619. end;
  4620. function timplementedinterfaces.searchintf(def: tdef): longint;
  4621. begin
  4622. for result := 1 to count do
  4623. if tdef(interfaces(result)) = def then
  4624. exit;
  4625. result := -1;
  4626. end;
  4627. procedure timplementedinterfaces.buildderef;
  4628. var
  4629. i: longint;
  4630. begin
  4631. for i:=1 to count do
  4632. with timplintfentry(finterfaces.search(i)) do
  4633. intfderef.build(intf);
  4634. end;
  4635. procedure timplementedinterfaces.deref;
  4636. var
  4637. i: longint;
  4638. begin
  4639. for i:=1 to count do
  4640. with timplintfentry(finterfaces.search(i)) do
  4641. intf:=tobjectdef(intfderef.resolve);
  4642. end;
  4643. procedure timplementedinterfaces.addintf_deref(const d:tderef;iofs:longint);
  4644. var
  4645. hintf : timplintfentry;
  4646. begin
  4647. hintf:=timplintfentry.create_deref(d);
  4648. hintf.ioffset:=iofs;
  4649. finterfaces.insert(hintf);
  4650. end;
  4651. procedure timplementedinterfaces.addintf_ioffset(d:tdef;iofs:longint);
  4652. var
  4653. hintf : timplintfentry;
  4654. begin
  4655. hintf:=timplintfentry.create(tobjectdef(d));
  4656. hintf.ioffset:=iofs;
  4657. finterfaces.insert(hintf);
  4658. end;
  4659. procedure timplementedinterfaces.addintf(def: tdef);
  4660. begin
  4661. if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
  4662. not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4663. internalerror(200006124);
  4664. finterfaces.insert(timplintfentry.create(tobjectdef(def)));
  4665. end;
  4666. procedure timplementedinterfaces.clearmappings;
  4667. var
  4668. i: longint;
  4669. begin
  4670. for i:=1 to count do
  4671. with timplintfentry(finterfaces.search(i)) do
  4672. begin
  4673. if assigned(namemappings) then
  4674. namemappings.free;
  4675. namemappings:=nil;
  4676. end;
  4677. end;
  4678. procedure timplementedinterfaces.addmappings(intfindex: longint; const origname, newname: string);
  4679. begin
  4680. checkindex(intfindex);
  4681. with timplintfentry(finterfaces.search(intfindex)) do
  4682. begin
  4683. if not assigned(namemappings) then
  4684. namemappings:=tdictionary.create;
  4685. namemappings.insert(tnamemap.create(origname,newname));
  4686. end;
  4687. end;
  4688. function timplementedinterfaces.getmappings(intfindex: longint; const origname: string; var nextexist: pointer): string;
  4689. begin
  4690. checkindex(intfindex);
  4691. if not assigned(nextexist) then
  4692. with timplintfentry(finterfaces.search(intfindex)) do
  4693. begin
  4694. if assigned(namemappings) then
  4695. nextexist:=namemappings.search(origname)
  4696. else
  4697. nextexist:=nil;
  4698. end;
  4699. if assigned(nextexist) then
  4700. begin
  4701. getmappings:=tnamemap(nextexist).newname^;
  4702. nextexist:=tnamemap(nextexist).listnext;
  4703. end
  4704. else
  4705. getmappings:='';
  4706. end;
  4707. procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
  4708. var
  4709. found : boolean;
  4710. i : longint;
  4711. begin
  4712. checkindex(intfindex);
  4713. with timplintfentry(finterfaces.search(intfindex)) do
  4714. begin
  4715. if not assigned(procdefs) then
  4716. procdefs:=tindexarray.create(4);
  4717. { No duplicate entries of the same procdef }
  4718. found:=false;
  4719. for i:=1 to procdefs.count do
  4720. if tprocdefstore(procdefs.search(i)).procdef=procdef then
  4721. begin
  4722. found:=true;
  4723. break;
  4724. end;
  4725. if not found then
  4726. procdefs.insert(tprocdefstore.create(procdef));
  4727. end;
  4728. end;
  4729. function timplementedinterfaces.implproccount(intfindex: longint): longint;
  4730. begin
  4731. checkindex(intfindex);
  4732. with timplintfentry(finterfaces.search(intfindex)) do
  4733. if assigned(procdefs) then
  4734. implproccount:=procdefs.count
  4735. else
  4736. implproccount:=0;
  4737. end;
  4738. function timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
  4739. begin
  4740. checkindex(intfindex);
  4741. with timplintfentry(finterfaces.search(intfindex)) do
  4742. if assigned(procdefs) then
  4743. implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
  4744. else
  4745. internalerror(200006131);
  4746. end;
  4747. function timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  4748. var
  4749. possible: boolean;
  4750. i: longint;
  4751. iiep1: TIndexArray;
  4752. iiep2: TIndexArray;
  4753. begin
  4754. checkindex(intfindex);
  4755. checkindex(remainindex);
  4756. iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
  4757. iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
  4758. if not assigned(iiep1) then { empty interface is mergeable :-) }
  4759. begin
  4760. possible:=true;
  4761. weight:=0;
  4762. end
  4763. else
  4764. begin
  4765. possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
  4766. i:=1;
  4767. while (possible) and (i<=iiep1.count) do
  4768. begin
  4769. possible:=
  4770. (tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
  4771. inc(i);
  4772. end;
  4773. if possible then
  4774. weight:=iiep1.count;
  4775. end;
  4776. isimplmergepossible:=possible;
  4777. end;
  4778. {****************************************************************************
  4779. TFORWARDDEF
  4780. ****************************************************************************}
  4781. constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
  4782. begin
  4783. inherited create(forwarddef);
  4784. tosymname:=stringdup(s);
  4785. forwardpos:=pos;
  4786. end;
  4787. function tforwarddef.GetTypeName:string;
  4788. begin
  4789. GetTypeName:='unresolved forward to '+tosymname^;
  4790. end;
  4791. destructor tforwarddef.destroy;
  4792. begin
  4793. if assigned(tosymname) then
  4794. stringdispose(tosymname);
  4795. inherited destroy;
  4796. end;
  4797. {****************************************************************************
  4798. TUNDEFINEDDEF
  4799. ****************************************************************************}
  4800. constructor tundefineddef.create;
  4801. begin
  4802. inherited create(undefineddef);
  4803. end;
  4804. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  4805. begin
  4806. inherited ppuload(undefineddef,ppufile);
  4807. end;
  4808. function tundefineddef.GetTypeName:string;
  4809. begin
  4810. GetTypeName:='<undefined type>';
  4811. end;
  4812. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  4813. begin
  4814. inherited ppuwrite(ppufile);
  4815. ppufile.writeentry(ibundefineddef);
  4816. end;
  4817. {****************************************************************************
  4818. TERRORDEF
  4819. ****************************************************************************}
  4820. constructor terrordef.create;
  4821. begin
  4822. inherited create(errordef);
  4823. end;
  4824. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  4825. begin
  4826. { Can't write errordefs to ppu }
  4827. internalerror(200411063);
  4828. end;
  4829. function terrordef.GetTypeName:string;
  4830. begin
  4831. GetTypeName:='<erroneous type>';
  4832. end;
  4833. function terrordef.getmangledparaname:string;
  4834. begin
  4835. getmangledparaname:='error';
  4836. end;
  4837. {****************************************************************************
  4838. Definition Helpers
  4839. ****************************************************************************}
  4840. function is_interfacecom(def: tdef): boolean;
  4841. begin
  4842. is_interfacecom:=
  4843. assigned(def) and
  4844. (def.deftype=objectdef) and
  4845. (tobjectdef(def).objecttype=odt_interfacecom);
  4846. end;
  4847. function is_interfacecorba(def: tdef): boolean;
  4848. begin
  4849. is_interfacecorba:=
  4850. assigned(def) and
  4851. (def.deftype=objectdef) and
  4852. (tobjectdef(def).objecttype=odt_interfacecorba);
  4853. end;
  4854. function is_interface(def: tdef): boolean;
  4855. begin
  4856. is_interface:=
  4857. assigned(def) and
  4858. (def.deftype=objectdef) and
  4859. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  4860. end;
  4861. function is_dispinterface(def: tdef): boolean;
  4862. begin
  4863. result:=
  4864. assigned(def) and
  4865. (def.deftype=objectdef) and
  4866. (tobjectdef(def).objecttype=odt_dispinterface);
  4867. end;
  4868. function is_class(def: tdef): boolean;
  4869. begin
  4870. is_class:=
  4871. assigned(def) and
  4872. (def.deftype=objectdef) and
  4873. (tobjectdef(def).objecttype=odt_class);
  4874. end;
  4875. function is_object(def: tdef): boolean;
  4876. begin
  4877. is_object:=
  4878. assigned(def) and
  4879. (def.deftype=objectdef) and
  4880. (tobjectdef(def).objecttype=odt_object);
  4881. end;
  4882. function is_cppclass(def: tdef): boolean;
  4883. begin
  4884. is_cppclass:=
  4885. assigned(def) and
  4886. (def.deftype=objectdef) and
  4887. (tobjectdef(def).objecttype=odt_cppclass);
  4888. end;
  4889. function is_class_or_interface(def: tdef): boolean;
  4890. begin
  4891. is_class_or_interface:=
  4892. assigned(def) and
  4893. (def.deftype=objectdef) and
  4894. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  4895. end;
  4896. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  4897. begin
  4898. result:=
  4899. assigned(def) and
  4900. (def.deftype=objectdef) and
  4901. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  4902. end;
  4903. {$ifdef x86}
  4904. function use_sse(def : tdef) : boolean;
  4905. begin
  4906. use_sse:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  4907. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  4908. end;
  4909. {$endif x86}
  4910. end.