symtable.pas 166 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  3. This unit handles the symbol tables
  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 symtable;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cutils,cclasses,globtype,tokens,
  23. { symtable }
  24. symconst,symbase,symtype,symdef,symsym;
  25. {****************************************************************************
  26. Symtable types
  27. ****************************************************************************}
  28. type
  29. tstoredsymtable = class(TSymtable)
  30. private
  31. init_final_check_done : boolean;
  32. procedure _needs_init_final(sym:TObject;arg:pointer);
  33. procedure check_forward(sym:TObject;arg:pointer);
  34. procedure check_block_valid(def: TObject;arg:pointer);
  35. procedure labeldefined(sym:TObject;arg:pointer);
  36. procedure varsymbolused(sym:TObject;arg:pointer);
  37. procedure TestPrivate(sym:TObject;arg:pointer);
  38. procedure objectprivatesymbolused(sym:TObject;arg:pointer);
  39. procedure loaddefs(ppufile:tcompilerppufile);
  40. procedure loadsyms(ppufile:tcompilerppufile);
  41. procedure writedefs(ppufile:tcompilerppufile);
  42. procedure writesyms(ppufile:tcompilerppufile);
  43. public
  44. constructor create(const s:string);
  45. procedure insert(sym:TSymEntry;checkdup:boolean=true);override;
  46. procedure delete(sym:TSymEntry);override;
  47. { load/write }
  48. procedure ppuload(ppufile:tcompilerppufile);virtual;
  49. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  50. procedure buildderef;
  51. procedure buildderefimpl;
  52. { buildderef but only for (recursively) used symbols/defs }
  53. procedure buildderef_registered;
  54. procedure deref(only_registered: boolean);virtual;
  55. procedure derefimpl(only_registered: boolean);virtual;
  56. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  57. procedure allsymbolsused;
  58. procedure allprivatesused;
  59. procedure check_forwards;
  60. procedure checklabels;
  61. function needs_init_final : boolean;
  62. procedure testfordefaultproperty(sym:TObject;arg:pointer);
  63. end;
  64. {$ifdef llvm}
  65. tllvmshadowsymtableentry = class
  66. constructor create(def: tdef; fieldoffset: aint);
  67. private
  68. ffieldoffset: aint;
  69. fdef: tdef;
  70. public
  71. property fieldoffset: aint read ffieldoffset;
  72. property def: tdef read fdef;
  73. end;
  74. tllvmshadowsymtable = class;
  75. {$endif llvm}
  76. tabstractrecordsymtable = class(tstoredsymtable)
  77. {$ifdef llvm}
  78. private
  79. fllvmst: tllvmshadowsymtable;
  80. function getllvmshadowsymtabll: tllvmshadowsymtable;
  81. {$endif llvm}
  82. public
  83. usefieldalignment, { alignment to use for fields (PACKRECORDS value), C_alignment is C style }
  84. recordalignment, { alignment desired when inserting this record }
  85. fieldalignment, { alignment current alignment used when fields are inserted }
  86. padalignment : shortint; { size to a multiple of which the symtable has to be rounded up }
  87. recordalignmin, { local equivalents of global settings, so that records can }
  88. maxCrecordalign: shortint; { be created with custom settings internally }
  89. constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  90. destructor destroy;override;
  91. procedure ppuload(ppufile:tcompilerppufile);override;
  92. procedure ppuwrite(ppufile:tcompilerppufile);override;
  93. procedure alignrecord(fieldoffset:asizeint;varalign:shortint);
  94. procedure addfield(sym:tfieldvarsym;vis:tvisibility);
  95. procedure addfieldlist(list: tfpobjectlist; maybereorder: boolean);
  96. { returns the field closest to this offset (may not be exact because
  97. of padding; internalerrors for variant records, assumes fields are
  98. ordered by increasing offset) }
  99. function findfieldbyoffset(offset:asizeint): tfieldvarsym;
  100. procedure addalignmentpadding;
  101. procedure insertdef(def:TDefEntry);override;
  102. function is_packed: boolean;
  103. function has_single_field(out def:tdef): boolean;
  104. function get_unit_symtable: tsymtable;
  105. protected
  106. { size in bytes including padding }
  107. _datasize : asizeint;
  108. { size in bits of the data in case of bitpacked record. Only important during construction, }
  109. { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8. }
  110. databitsize : asizeint;
  111. { size in bytes of padding }
  112. _paddingsize : word;
  113. procedure setdatasize(val: asizeint);
  114. function getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint;
  115. public
  116. function iscurrentunit: boolean; override;
  117. property datasize : asizeint read _datasize write setdatasize;
  118. property paddingsize: word read _paddingsize write _paddingsize;
  119. {$ifdef llvm}
  120. property llvmst: tllvmshadowsymtable read getllvmshadowsymtabll;
  121. {$endif llvm}
  122. end;
  123. trecordsymtable = class(tabstractrecordsymtable)
  124. public
  125. { maybe someday is worth to move managementoperators to }
  126. { tabstractrecordsymtable to perform management class operators for }
  127. { object/classes. In XE5 and newer is possible to use class operator }
  128. { for classes (like for Delphi .NET before) only for Delphi NEXTGEN }
  129. managementoperators : tmanagementoperators;
  130. constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  131. procedure insertunionst(unionst : trecordsymtable;offset : longint);
  132. procedure includemanagementoperator(mop:tmanagementoperator);
  133. end;
  134. tObjectSymtable = class(tabstractrecordsymtable)
  135. public
  136. constructor create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  137. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  138. end;
  139. {$ifdef llvm}
  140. { llvm record definitions cannot contain variant/union parts, }
  141. { you have to flatten them first. the tllvmshadowsymtable }
  142. { contains a flattened version of a record/object symtable }
  143. tllvmshadowsymtable = class
  144. private
  145. equivst: tabstractrecordsymtable;
  146. curroffset: aint;
  147. function get(f: tfieldvarsym): tllvmshadowsymtableentry;
  148. function get_by_llvm_index(index: longint): tllvmshadowsymtableentry;
  149. public
  150. symdeflist: TFPObjectList;
  151. constructor create(st: tabstractrecordsymtable);
  152. destructor destroy; override;
  153. property entries[index: tfieldvarsym]: tllvmshadowsymtableentry read get; default;
  154. { warning: do not call this with field.llvmfieldnr, as
  155. field.llvmfieldnr will only be initialised when the llvm shadow
  156. symtable is accessed for the first time. Use the default/entries
  157. property instead in this case }
  158. property entries_by_llvm_index[index: longint]: tllvmshadowsymtableentry read get_by_llvm_index;
  159. private
  160. // generate the table
  161. procedure generate;
  162. // helpers
  163. procedure appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean);
  164. procedure findvariantstarts(variantstarts: tfplist);
  165. procedure addalignmentpadding(finalsize: aint);
  166. procedure buildmapping(variantstarts: tfplist);
  167. procedure buildtable(variantstarts: tfplist);
  168. end;
  169. {$endif llvm}
  170. { tabstractsubsymtable }
  171. tabstractsubsymtable = class(tstoredsymtable)
  172. public
  173. procedure ppuwrite(ppufile:tcompilerppufile);override;
  174. end;
  175. { tabstractlocalsymtable }
  176. tabstractlocalsymtable = class(tabstractsubsymtable)
  177. public
  178. function count_locals:longint;
  179. function iscurrentunit: boolean; override;
  180. end;
  181. tlocalsymtable = class(tabstractlocalsymtable)
  182. public
  183. constructor create(adefowner:tdef;level:byte);
  184. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  185. end;
  186. { tparasymtable }
  187. tparasymtable = class(tabstractlocalsymtable)
  188. public
  189. readonly: boolean;
  190. constructor create(adefowner:tdef;level:byte);
  191. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  192. procedure insertdef(def:TDefEntry);override;
  193. end;
  194. tabstractuniTSymtable = class(tstoredsymtable)
  195. public
  196. constructor create(const n : string;id:word);
  197. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  198. function findnamespace(const n:string):TSymEntry;virtual;
  199. function iscurrentunit:boolean;override;
  200. procedure insertunit(sym:TSymEntry);
  201. end;
  202. tglobalsymtable = class(tabstractuniTSymtable)
  203. public
  204. unittypecount : word;
  205. constructor create(const n : string;id:word);
  206. procedure ppuload(ppufile:tcompilerppufile);override;
  207. procedure ppuwrite(ppufile:tcompilerppufile);override;
  208. end;
  209. tstaticsymtable = class(tabstractuniTSymtable)
  210. public
  211. constructor create(const n : string;id:word);
  212. procedure ppuload(ppufile:tcompilerppufile);override;
  213. procedure ppuwrite(ppufile:tcompilerppufile);override;
  214. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  215. function findnamespace(const n:string):TSymEntry;override;
  216. end;
  217. tspecializesymtable = class(tglobalsymtable)
  218. public
  219. constructor create(const n : string;id:word);
  220. function iscurrentunit:boolean;override;
  221. end;
  222. twithsymtable = class(TSymtable)
  223. withrefnode : tobject; { tnode }
  224. constructor create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
  225. destructor destroy;override;
  226. procedure clear;override;
  227. procedure insertdef(def:TDefEntry);override;
  228. end;
  229. tstt_excepTSymtable = class(TSymtable)
  230. public
  231. constructor create;
  232. end;
  233. tmacrosymtable = class(tstoredsymtable)
  234. public
  235. constructor create(exported: boolean);
  236. end;
  237. { tenumsymtable }
  238. tenumsymtable = class(tabstractsubsymtable)
  239. public
  240. procedure insert(sym: TSymEntry; checkdup: boolean = true); override;
  241. constructor create(adefowner:tdef);
  242. end;
  243. { tarraysymtable }
  244. tarraysymtable = class(tabstractsubsymtable)
  245. public
  246. procedure insertdef(def:TDefEntry);override;
  247. constructor create(adefowner:tdef);
  248. end;
  249. var
  250. systemunit : tglobalsymtable; { pointer to the system unit }
  251. type
  252. tsymbol_search_flag = (
  253. ssf_search_option,
  254. ssf_search_helper,
  255. ssf_has_inherited,
  256. ssf_no_addsymref
  257. );
  258. tsymbol_search_flags = set of tsymbol_search_flag;
  259. {****************************************************************************
  260. Functions
  261. ****************************************************************************}
  262. {*** Misc ***}
  263. function FullTypeName(def,otherdef:tdef):string;
  264. function generate_nested_name(symtable:tsymtable;delimiter:string):string;
  265. { def is the extended type of a helper }
  266. function generate_objectpascal_helper_key(def:tdef):string;
  267. procedure incompatibletypes(def1,def2:tdef);
  268. procedure hidesym(sym:TSymEntry);
  269. procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym:TSymEntry; warn: boolean);
  270. function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean;
  271. { writes all declarations for the specified system unit symbol }
  272. procedure write_system_parameter_lists(const name:string);
  273. {*** Search ***}
  274. procedure addsymref(sym:tsym);
  275. function is_owned_by(nesteddef,ownerdef:tdef):boolean;
  276. function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
  277. function defs_belong_to_same_generic(def1,def2:tdef):boolean;
  278. function get_generic_in_hierarchy_by_name(srsym:tsym;def:tdef):tdef;
  279. function return_specialization_of_generic(nesteddef,genericdef:tdef;out resultdef:tdef):boolean;
  280. function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
  281. function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
  282. function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
  283. function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  284. function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  285. function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
  286. { searches for a symbol with the given name that has the given option in
  287. symoptions set }
  288. function searchsym_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;option:tsymoption):boolean;
  289. function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  290. function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  291. function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
  292. function searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  293. function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  294. function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
  295. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
  296. { searches symbols inside of a helper's implementation }
  297. function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  298. function search_system_type(const s: TIDString): ttypesym;
  299. function try_search_system_type(const s: TIDString): ttypesym;
  300. function try_search_current_module_type(const s: TIDString): ttypesym;
  301. function search_system_proc(const s: TIDString): tprocdef;
  302. function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
  303. function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
  304. function search_struct_member_no_helper(pd : tabstractrecorddef;const s : string):tsym;
  305. function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
  306. function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef;
  307. { searches for the helper definition that's currently active for pd }
  308. function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
  309. { searches whether the symbol s is available in the currently active }
  310. { helper for pd }
  311. function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  312. function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  313. function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  314. {Looks for macro s (must be given in upper case) in the macrosymbolstack, }
  315. {and returns it if found. Returns nil otherwise.}
  316. function search_macro(const s : string):tsym;
  317. { Additionally to searching for a macro, also checks whether it's still }
  318. { actually defined (could be disable using "undef") }
  319. function defined_macro(const s : string):boolean;
  320. { Look for a system procedure (no overloads supported) }
  321. {*** Object Helpers ***}
  322. function search_default_property(pd : tabstractrecorddef) : tpropertysym;
  323. function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef;
  324. function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
  325. {*** Macro Helpers ***}
  326. {If called initially, the following procedures manipulate macros in }
  327. {initialmacrotable, otherwise they manipulate system macros local to a module.}
  328. {Name can be given in any case (it will be converted to upper case).}
  329. procedure def_system_macro(const name : string);
  330. procedure set_system_macro(const name, value : string);
  331. procedure set_system_compvar(const name, value : string);
  332. procedure undef_system_macro(const name : string);
  333. {*** symtable stack ***}
  334. { $ifdef DEBUG
  335. procedure test_symtablestack;
  336. procedure list_symtablestack;
  337. $endif DEBUG}
  338. {$ifdef UNITALIASES}
  339. type
  340. punit_alias = ^tunit_alias;
  341. tunit_alias = object(TNamedIndexItem)
  342. newname : pshortstring;
  343. constructor init(const n:string);
  344. destructor done;virtual;
  345. end;
  346. var
  347. unitaliases : pdictionary;
  348. procedure addunitalias(const n:string);
  349. function getunitalias(const n:string):string;
  350. {$endif UNITALIASES}
  351. {*** Init / Done ***}
  352. procedure IniTSymtable;
  353. procedure DoneSymtable;
  354. const
  355. overloaded_names : array [NOTOKEN..last_overloaded] of string[16] = (
  356. { NOTOKEN } 'error',
  357. { _PLUS } 'plus',
  358. { _MINUS } 'minus',
  359. { _STAR } 'star',
  360. { _SLASH } 'slash',
  361. { _EQ } 'equal',
  362. { _GT } 'greater',
  363. { _LT } 'lower',
  364. { _GTE } 'greater_or_equal',
  365. { _LTE } 'lower_or_equal',
  366. { _NE } 'not_equal',
  367. { _SYMDIF } 'sym_diff',
  368. { _STARSTAR } 'starstar',
  369. { _OP_AS } 'as',
  370. { _OP_IN } 'in',
  371. { _OP_IS } 'is',
  372. { _OP_OR } 'or',
  373. { _OP_AND } 'and',
  374. { _OP_DIV } 'div',
  375. { _OP_MOD } 'mod',
  376. { _OP_NOT } 'not',
  377. { _OP_SHL } 'shl',
  378. { _OP_SHR } 'shr',
  379. { _OP_XOR } 'xor',
  380. { _ASSIGNMENT } 'assign',
  381. { _OP_EXPLICIT } 'explicit',
  382. { _OP_ENUMERATOR } 'enumerator',
  383. { _OP_INITIALIZE } 'initialize',
  384. { _OP_FINALIZE } 'finalize',
  385. { _OP_ADDREF } 'addref',
  386. { _OP_COPY } 'copy',
  387. { _OP_INC } 'inc',
  388. { _OP_DEC } 'dec');
  389. implementation
  390. uses
  391. { global }
  392. verbose,globals,
  393. { symtable }
  394. symutil,defutil,defcmp,objcdef,
  395. { module }
  396. fmodule,
  397. { codegen }
  398. procinfo,
  399. { ppu }
  400. entfile
  401. ;
  402. var
  403. dupnr : longint; { unique number for duplicate symbols }
  404. {*****************************************************************************
  405. TStoredSymtable
  406. *****************************************************************************}
  407. constructor tstoredsymtable.create(const s:string);
  408. begin
  409. inherited create(s);
  410. { Note: this happens for the initial macro symtable, so no error here }
  411. if not assigned(current_module) then
  412. comment(v_debug,'Current module not available for module id')
  413. else
  414. moduleid:=current_module.moduleid;
  415. end;
  416. procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true);
  417. begin
  418. inherited insert(sym,checkdup);
  419. init_final_check_done:=false;
  420. end;
  421. procedure tstoredsymtable.delete(sym:TSymEntry);
  422. begin
  423. inherited delete(sym);
  424. init_final_check_done:=false;
  425. end;
  426. procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
  427. begin
  428. { load the table's flags }
  429. if ppufile.readentry<>ibsymtableoptions then
  430. Message(unit_f_ppu_read_error);
  431. ppufile.getsmallset(tableoptions);
  432. { load definitions }
  433. loaddefs(ppufile);
  434. { load symbols }
  435. loadsyms(ppufile);
  436. init_final_check_done:=true;
  437. end;
  438. procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile);
  439. begin
  440. { ensure that we have the sto_needs_init_final flag set if needed }
  441. if not init_final_check_done then
  442. needs_init_final;
  443. { write the table's flags }
  444. ppufile.putsmallset(tableoptions);
  445. ppufile.writeentry(ibsymtableoptions);
  446. { write definitions }
  447. writedefs(ppufile);
  448. { write symbols }
  449. writesyms(ppufile);
  450. end;
  451. procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile);
  452. var
  453. def : tdef;
  454. b : byte;
  455. begin
  456. def:=nil;
  457. { load start of definition section, which holds the amount of defs }
  458. if ppufile.readentry<>ibstartdefs then
  459. Message(unit_f_ppu_read_error);
  460. { read definitions }
  461. repeat
  462. b:=ppufile.readentry;
  463. case b of
  464. ibpointerdef : def:=cpointerdef.ppuload(ppufile);
  465. ibarraydef : def:=carraydef.ppuload(ppufile);
  466. iborddef : def:=corddef.ppuload(ppufile);
  467. ibfloatdef : def:=cfloatdef.ppuload(ppufile);
  468. ibprocdef : def:=cprocdef.ppuload(ppufile);
  469. ibshortstringdef : def:=cstringdef.loadshort(ppufile);
  470. iblongstringdef : def:=cstringdef.loadlong(ppufile);
  471. ibansistringdef : def:=cstringdef.loadansi(ppufile);
  472. ibwidestringdef : def:=cstringdef.loadwide(ppufile);
  473. ibunicodestringdef : def:=cstringdef.loadunicode(ppufile);
  474. ibrecorddef : def:=crecorddef.ppuload(ppufile);
  475. ibobjectdef : def:=cobjectdef.ppuload(ppufile);
  476. ibenumdef : def:=cenumdef.ppuload(ppufile);
  477. ibsetdef : def:=csetdef.ppuload(ppufile);
  478. ibprocvardef : def:=cprocvardef.ppuload(ppufile);
  479. ibfiledef : def:=cfiledef.ppuload(ppufile);
  480. ibclassrefdef : def:=cclassrefdef.ppuload(ppufile);
  481. ibformaldef : def:=cformaldef.ppuload(ppufile);
  482. ibvariantdef : def:=cvariantdef.ppuload(ppufile);
  483. ibundefineddef : def:=cundefineddef.ppuload(ppufile);
  484. ibenddefs : break;
  485. ibend : Message(unit_f_ppu_read_error);
  486. else
  487. Message1(unit_f_ppu_invalid_entry,tostr(b));
  488. end;
  489. InsertDef(def);
  490. until false;
  491. end;
  492. procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile);
  493. var
  494. b : byte;
  495. sym : tsym;
  496. begin
  497. sym:=nil;
  498. { load start of definition section, which holds the amount of defs }
  499. if ppufile.readentry<>ibstartsyms then
  500. Message(unit_f_ppu_read_error);
  501. { now read the symbols }
  502. repeat
  503. b:=ppufile.readentry;
  504. case b of
  505. ibtypesym : sym:=ctypesym.ppuload(ppufile);
  506. ibprocsym : sym:=cprocsym.ppuload(ppufile);
  507. ibconstsym : sym:=cconstsym.ppuload(ppufile);
  508. ibstaticvarsym : sym:=cstaticvarsym.ppuload(ppufile);
  509. iblocalvarsym : sym:=clocalvarsym.ppuload(ppufile);
  510. ibparavarsym : sym:=cparavarsym.ppuload(ppufile);
  511. ibfieldvarsym : sym:=cfieldvarsym.ppuload(ppufile);
  512. ibabsolutevarsym : sym:=cabsolutevarsym.ppuload(ppufile);
  513. ibenumsym : sym:=cenumsym.ppuload(ppufile);
  514. ibpropertysym : sym:=cpropertysym.ppuload(ppufile);
  515. ibunitsym : sym:=cunitsym.ppuload(ppufile);
  516. iblabelsym : sym:=clabelsym.ppuload(ppufile);
  517. ibsyssym : sym:=csyssym.ppuload(ppufile);
  518. ibmacrosym : sym:=tmacro.ppuload(ppufile);
  519. ibnamespacesym : sym:=cnamespacesym.ppuload(ppufile);
  520. ibendsyms : break;
  521. ibend : Message(unit_f_ppu_read_error);
  522. else
  523. Message1(unit_f_ppu_invalid_entry,tostr(b));
  524. end;
  525. Insert(sym,false);
  526. until false;
  527. end;
  528. procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile);
  529. var
  530. defcount,
  531. i : longint;
  532. def : tstoreddef;
  533. begin
  534. defcount:=0;
  535. for i:=0 to DefList.Count-1 do
  536. if tstoreddef(DefList[i]).is_registered then
  537. inc(defcount);
  538. { each definition get a number, write then the amount of defs to the
  539. ibstartdef entry }
  540. ppufile.putlongint(defcount);
  541. ppufile.writeentry(ibstartdefs);
  542. { now write the definition }
  543. for i:=0 to DefList.Count-1 do
  544. begin
  545. def:=tstoreddef(DefList[i]);
  546. if def.is_registered then
  547. def.ppuwrite(ppufile);
  548. end;
  549. { write end of definitions }
  550. ppufile.writeentry(ibenddefs);
  551. end;
  552. procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile);
  553. var
  554. symcount,
  555. i : longint;
  556. sym : Tstoredsym;
  557. begin
  558. symcount:=0;
  559. for i:=0 to SymList.Count-1 do
  560. if tstoredsym(SymList[i]).is_registered then
  561. inc(symcount);
  562. { each definition get a number, write then the amount of syms and the
  563. datasize to the ibsymdef entry }
  564. ppufile.putlongint(symcount);
  565. ppufile.writeentry(ibstartsyms);
  566. { foreach is used to write all symbols }
  567. for i:=0 to SymList.Count-1 do
  568. begin
  569. sym:=tstoredsym(SymList[i]);
  570. if sym.is_registered then
  571. sym.ppuwrite(ppufile);
  572. end;
  573. { end of symbols }
  574. ppufile.writeentry(ibendsyms);
  575. end;
  576. procedure tstoredsymtable.buildderef;
  577. var
  578. i : longint;
  579. def : tstoreddef;
  580. sym : tstoredsym;
  581. begin
  582. { interface definitions }
  583. for i:=0 to DefList.Count-1 do
  584. begin
  585. def:=tstoreddef(DefList[i]);
  586. def.buildderef;
  587. end;
  588. { interface symbols }
  589. for i:=0 to SymList.Count-1 do
  590. begin
  591. sym:=tstoredsym(SymList[i]);
  592. sym.buildderef;
  593. end;
  594. end;
  595. procedure tstoredsymtable.buildderefimpl;
  596. var
  597. i : longint;
  598. def : tstoreddef;
  599. begin
  600. { implementation definitions }
  601. for i:=0 to DefList.Count-1 do
  602. begin
  603. def:=tstoreddef(DefList[i]);
  604. def.buildderefimpl;
  605. end;
  606. end;
  607. procedure tstoredsymtable.buildderef_registered;
  608. var
  609. def : tstoreddef;
  610. sym : tstoredsym;
  611. i : longint;
  612. defidmax,
  613. symidmax: longint;
  614. newbuiltdefderefs,
  615. builtdefderefs,
  616. builtsymderefs: array of boolean;
  617. begin
  618. { tdefs for which we already built the deref }
  619. setlength(builtdefderefs,deflist.count);
  620. { tdefs for which we built the deref in this iteration }
  621. setlength(newbuiltdefderefs,deflist.count);
  622. { syms for which we already built the deref }
  623. setlength(builtsymderefs,symlist.count);
  624. repeat
  625. { we only have to store the defs (recursively) referred by wpo info
  626. or inlined routines in the static symbtable }
  627. { current number of registered defs/syms }
  628. defidmax:=current_module.deflist.count;
  629. symidmax:=current_module.symlist.count;
  630. { build the derefs for the registered defs we haven't processed yet }
  631. for i:=0 to DefList.Count-1 do
  632. begin
  633. if not builtdefderefs[i] then
  634. begin
  635. def:=tstoreddef(DefList[i]);
  636. if def.is_registered then
  637. begin
  638. def.buildderef;
  639. newbuiltdefderefs[i]:=true;
  640. builtdefderefs[i]:=true;
  641. end;
  642. end;
  643. end;
  644. { same for the syms }
  645. for i:=0 to SymList.Count-1 do
  646. begin
  647. if not builtsymderefs[i] then
  648. begin
  649. sym:=tstoredsym(SymList[i]);
  650. if sym.is_registered then
  651. begin
  652. sym.buildderef;
  653. builtsymderefs[i]:=true;
  654. end;
  655. end;
  656. end;
  657. { now buildderefimpl for the defs we processed in this iteration }
  658. for i:=0 to DefList.Count-1 do
  659. begin
  660. if newbuiltdefderefs[i] then
  661. begin
  662. newbuiltdefderefs[i]:=false;
  663. tstoreddef(DefList[i]).buildderefimpl;
  664. end;
  665. end;
  666. { stop when no new defs or syms have been registered while processing
  667. the currently registered ones (defs/syms get added to the module's
  668. deflist/symlist when they are registered) }
  669. until
  670. (defidmax=current_module.deflist.count) and
  671. (symidmax=current_module.symlist.count);
  672. end;
  673. procedure tstoredsymtable.deref(only_registered: boolean);
  674. var
  675. i : longint;
  676. def : tstoreddef;
  677. sym : tstoredsym;
  678. begin
  679. { first deref the interface ttype symbols. This is needs
  680. to be done before the interface defs are derefed, because
  681. the interface defs can contain references to the type symbols
  682. which then already need to contain a resolved typedef field (PFV) }
  683. for i:=0 to SymList.Count-1 do
  684. begin
  685. sym:=tstoredsym(SymList[i]);
  686. if (sym.typ=typesym) and
  687. (not only_registered or
  688. sym.is_registered) then
  689. sym.deref;
  690. end;
  691. { interface definitions }
  692. for i:=0 to DefList.Count-1 do
  693. begin
  694. def:=tstoreddef(DefList[i]);
  695. if not only_registered or
  696. def.is_registered then
  697. def.deref;
  698. end;
  699. { interface symbols }
  700. for i:=0 to SymList.Count-1 do
  701. begin
  702. sym:=tstoredsym(SymList[i]);
  703. if (not only_registered or
  704. sym.is_registered) and
  705. (sym.typ<>typesym) then
  706. sym.deref;
  707. end;
  708. end;
  709. procedure tstoredsymtable.derefimpl(only_registered: boolean);
  710. var
  711. i : longint;
  712. def : tstoreddef;
  713. begin
  714. { implementation definitions }
  715. for i:=0 to DefList.Count-1 do
  716. begin
  717. def:=tstoreddef(DefList[i]);
  718. if not only_registered or
  719. def.is_registered then
  720. def.derefimpl;
  721. end;
  722. end;
  723. function tstoredsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  724. var
  725. hsym : tsym;
  726. begin
  727. hsym:=tsym(FindWithHash(hashedid));
  728. if assigned(hsym) then
  729. DuplicateSym(hashedid,sym,hsym,false);
  730. result:=assigned(hsym);
  731. end;
  732. {**************************************
  733. Callbacks
  734. **************************************}
  735. procedure TStoredSymtable.check_forward(sym:TObject;arg:pointer);
  736. begin
  737. if tsym(sym).typ=procsym then
  738. tprocsym(sym).check_forward
  739. { check also object method table }
  740. { we needn't to test the def list }
  741. { because each object has to have a type sym,
  742. only test objects declarations, not type renamings }
  743. else
  744. if (tsym(sym).typ=typesym) and
  745. assigned(ttypesym(sym).typedef) and
  746. (ttypesym(sym).typedef.typesym=ttypesym(sym)) and
  747. (ttypesym(sym).typedef.typ in [objectdef,recorddef]) then
  748. tabstractrecorddef(ttypesym(sym).typedef).check_forwards;
  749. end;
  750. procedure tstoredsymtable.check_block_valid(def: TObject; arg: pointer);
  751. var
  752. founderrordef: tdef;
  753. begin
  754. { all parameters passed to a block must be handled by the Objective-C
  755. runtime }
  756. if is_block(tdef(def)) and
  757. not objcchecktype(tdef(def),founderrordef) then
  758. if assigned(tdef(def).typesym) then
  759. MessagePos1(tdef(def).typesym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename)
  760. else
  761. Message1(type_e_objc_type_unsupported,tprocvardef(def).typename)
  762. end;
  763. procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer);
  764. begin
  765. if (tsym(sym).typ=labelsym) and
  766. not(tlabelsym(sym).defined) then
  767. begin
  768. if tlabelsym(sym).used then
  769. Message1(sym_e_label_used_and_not_defined,tlabelsym(sym).realname)
  770. else
  771. Message1(sym_w_label_not_defined,tlabelsym(sym).realname);
  772. end;
  773. end;
  774. procedure TStoredSymtable.varsymbolused(sym:TObject;arg:pointer);
  775. begin
  776. if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and
  777. ((tsym(sym).owner.symtabletype in
  778. [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then
  779. begin
  780. { unused symbol should be reported only if no }
  781. { error is reported }
  782. { if the symbol is in a register it is used }
  783. { also don't count the value parameters which have local copies }
  784. { also don't claim for high param of open parameters (PM) }
  785. { also don't complain about unused symbols in generic procedures }
  786. { and methods }
  787. { and neither in abstract methods }
  788. if (Errorcount<>0) or
  789. ([vo_is_hidden_para,vo_is_funcret] * tabstractvarsym(sym).varoptions = [vo_is_hidden_para]) or
  790. (sp_internal in tsym(sym).symoptions) or
  791. ((assigned(tsym(sym).owner.defowner) and
  792. (tsym(sym).owner.defowner.typ=procdef) and
  793. ((df_generic in tprocdef(tsym(sym).owner.defowner).defoptions) or
  794. (po_abstractmethod in tprocdef(tsym(sym).owner.defowner).procoptions)))) then
  795. exit;
  796. if (tstoredsym(sym).refs=0) then
  797. begin
  798. if (vo_is_funcret in tabstractvarsym(sym).varoptions) then
  799. begin
  800. { don't warn about the result of constructors }
  801. if ((tsym(sym).owner.symtabletype<>localsymtable) or
  802. (tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and
  803. not (po_noreturn in tprocdef(tsym(sym).owner.defowner).procoptions) and
  804. not(cs_opt_nodedfa in current_settings.optimizerswitches) then
  805. MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set)
  806. end
  807. else if (tsym(sym).owner.symtabletype=parasymtable) then
  808. MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname)
  809. else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  810. MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
  811. else
  812. MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname);
  813. end
  814. else if tabstractvarsym(sym).varstate in [vs_written,vs_initialised] then
  815. begin
  816. if (tsym(sym).owner.symtabletype=parasymtable) then
  817. begin
  818. if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and
  819. not(vo_is_funcret in tabstractvarsym(sym).varoptions) then
  820. MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname)
  821. end
  822. else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  823. MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
  824. else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then
  825. MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname);
  826. end
  827. else if (tabstractvarsym(sym).varstate = vs_read_not_warned) and
  828. ([vo_is_public,vo_is_external] * tabstractvarsym(sym).varoptions = []) then
  829. MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname)
  830. end
  831. else if ((tsym(sym).owner.symtabletype in
  832. [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then
  833. begin
  834. if (Errorcount<>0) or
  835. (sp_internal in tsym(sym).symoptions) then
  836. exit;
  837. { do not claim for inherited private fields !! }
  838. if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  839. case tsym(sym).typ of
  840. typesym:
  841. MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  842. constsym:
  843. MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  844. propertysym:
  845. MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  846. else
  847. MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  848. end
  849. { units references are problematic }
  850. else
  851. begin
  852. if (tsym(sym).refs=0) and
  853. not(tsym(sym).typ in [enumsym,unitsym,namespacesym]) and
  854. not(is_funcret_sym(tsym(sym))) and
  855. { don't complain about compiler generated syms for specializations, see also #13405 }
  856. not((tsym(sym).typ=typesym) and (df_specialization in ttypesym(sym).typedef.defoptions) and
  857. (pos('$',ttypesym(sym).Realname)<>0)) and
  858. (
  859. (tsym(sym).typ<>procsym) or
  860. ((tsym(sym).owner.symtabletype=staticsymtable) and
  861. not current_module.is_unit)
  862. ) and
  863. { don't complain about alias for hidden _cmd parameter to
  864. obj-c methods }
  865. not((tsym(sym).typ in [localvarsym,paravarsym,absolutevarsym]) and
  866. (vo_is_msgsel in tabstractvarsym(sym).varoptions)) then
  867. MessagePos2(tsym(sym).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(sym).typ],tsym(sym).prettyname);
  868. end;
  869. end;
  870. end;
  871. procedure TStoredSymtable.TestPrivate(sym:TObject;arg:pointer);
  872. begin
  873. if tsym(sym).visibility in [vis_private,vis_strictprivate] then
  874. varsymbolused(sym,arg);
  875. end;
  876. procedure TStoredSymtable.objectprivatesymbolused(sym:TObject;arg:pointer);
  877. begin
  878. {
  879. Don't test simple object aliases PM
  880. }
  881. if (tsym(sym).typ=typesym) and
  882. (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and
  883. (ttypesym(sym).typedef.typesym=tsym(sym)) then
  884. tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil);
  885. end;
  886. procedure tstoredsymtable.testfordefaultproperty(sym:TObject;arg:pointer);
  887. begin
  888. if (tsym(sym).typ=propertysym) and
  889. (ppo_defaultproperty in tpropertysym(sym).propoptions) then
  890. ppointer(arg)^:=sym;
  891. end;
  892. {***********************************************
  893. Process all entries
  894. ***********************************************}
  895. { checks, if all procsyms and methods are defined }
  896. procedure tstoredsymtable.check_forwards;
  897. begin
  898. SymList.ForEachCall(@check_forward,nil);
  899. { check whether all block definitions contain valid Objective-C types
  900. (now that all forward definitions have been resolved) }
  901. DefList.ForEachCall(@check_block_valid,nil);
  902. end;
  903. procedure tstoredsymtable.checklabels;
  904. begin
  905. SymList.ForEachCall(@labeldefined,nil);
  906. end;
  907. procedure tstoredsymtable.allsymbolsused;
  908. begin
  909. SymList.ForEachCall(@varsymbolused,nil);
  910. end;
  911. procedure tstoredsymtable.allprivatesused;
  912. begin
  913. SymList.ForEachCall(@objectprivatesymbolused,nil);
  914. end;
  915. procedure TStoredSymtable._needs_init_final(sym:TObject;arg:pointer);
  916. begin
  917. if sto_needs_init_final in tableoptions then
  918. exit;
  919. { don't check static symbols - they can be present in structures only and
  920. always have a reference to a symbol defined on unit level }
  921. if sp_static in tsym(sym).symoptions then
  922. exit;
  923. case tsym(sym).typ of
  924. fieldvarsym,
  925. staticvarsym,
  926. localvarsym,
  927. paravarsym :
  928. begin
  929. if assigned(tabstractvarsym(sym).vardef) and
  930. is_managed_type(tabstractvarsym(sym).vardef) then
  931. include(tableoptions,sto_needs_init_final);
  932. end;
  933. end;
  934. end;
  935. { returns true, if p contains data which needs init/final code }
  936. function tstoredsymtable.needs_init_final : boolean;
  937. begin
  938. if not init_final_check_done then
  939. begin
  940. exclude(tableoptions,sto_needs_init_final);
  941. SymList.ForEachCall(@_needs_init_final,nil);
  942. init_final_check_done:=true;
  943. end;
  944. result:=sto_needs_init_final in tableoptions;
  945. end;
  946. {****************************************************************************
  947. TAbstractRecordSymtable
  948. ****************************************************************************}
  949. {$ifdef llvm}
  950. function tabstractrecordsymtable.getllvmshadowsymtabll: tllvmshadowsymtable;
  951. begin
  952. if not assigned(fllvmst) then
  953. fllvmst:=tllvmshadowsymtable.create(self);
  954. result:=fllvmst;
  955. end;
  956. {$endif llvm}
  957. constructor tabstractrecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  958. begin
  959. inherited create(n);
  960. _datasize:=0;
  961. databitsize:=0;
  962. recordalignment:=1;
  963. usefieldalignment:=usealign;
  964. recordalignmin:=recordminalign;
  965. maxCrecordalign:=recordmaxCalign;
  966. padalignment:=1;
  967. { recordalign C_alignment means C record packing, that starts
  968. with an alignment of 1 }
  969. case usealign of
  970. C_alignment,
  971. bit_alignment:
  972. fieldalignment:=1;
  973. mac68k_alignment:
  974. fieldalignment:=2;
  975. else
  976. fieldalignment:=usealign;
  977. end;
  978. end;
  979. destructor tabstractrecordsymtable.destroy;
  980. begin
  981. {$ifdef llvm}
  982. if refcount=1 then
  983. fllvmst.free;
  984. {$endif llvm}
  985. inherited destroy;
  986. end;
  987. procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile);
  988. begin
  989. if ppufile.readentry<>ibrecsymtableoptions then
  990. Message(unit_f_ppu_read_error);
  991. recordalignment:=shortint(ppufile.getbyte);
  992. usefieldalignment:=shortint(ppufile.getbyte);
  993. recordalignmin:=shortint(ppufile.getbyte);
  994. if (usefieldalignment=C_alignment) then
  995. fieldalignment:=shortint(ppufile.getbyte);
  996. inherited ppuload(ppufile);
  997. end;
  998. procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile);
  999. var
  1000. oldtyp : byte;
  1001. begin
  1002. oldtyp:=ppufile.entrytyp;
  1003. ppufile.entrytyp:=subentryid;
  1004. { in case of classes using C alignment, the alignment of the parent
  1005. affects the alignment of fields of the childs }
  1006. ppufile.putbyte(byte(recordalignment));
  1007. ppufile.putbyte(byte(usefieldalignment));
  1008. ppufile.putbyte(byte(recordalignmin));
  1009. if (usefieldalignment=C_alignment) then
  1010. ppufile.putbyte(byte(fieldalignment));
  1011. ppufile.writeentry(ibrecsymtableoptions);
  1012. inherited ppuwrite(ppufile);
  1013. ppufile.entrytyp:=oldtyp;
  1014. end;
  1015. function field2recordalignment(fieldoffs, fieldalign: asizeint): asizeint;
  1016. begin
  1017. { optimal alignment of the record when declaring a variable of this }
  1018. { type is independent of the packrecords setting }
  1019. if (fieldoffs mod fieldalign) = 0 then
  1020. result:=fieldalign
  1021. else if (fieldalign >= 16) and
  1022. ((fieldoffs mod 16) = 0) and
  1023. ((fieldalign mod 16) = 0) then
  1024. result:=16
  1025. else if (fieldalign >= 8) and
  1026. ((fieldoffs mod 8) = 0) and
  1027. ((fieldalign mod 8) = 0) then
  1028. result:=8
  1029. else if (fieldalign >= 4) and
  1030. ((fieldoffs mod 4) = 0) and
  1031. ((fieldalign mod 4) = 0) then
  1032. result:=4
  1033. else if (fieldalign >= 2) and
  1034. ((fieldoffs mod 2) = 0) and
  1035. ((fieldalign mod 2) = 0) then
  1036. result:=2
  1037. else
  1038. result:=1;
  1039. end;
  1040. procedure tabstractrecordsymtable.alignrecord(fieldoffset:asizeint;varalign:shortint);
  1041. var
  1042. varalignrecord: shortint;
  1043. begin
  1044. case usefieldalignment of
  1045. C_alignment:
  1046. varalignrecord:=used_align(varalign,recordalignmin,maxCrecordalign);
  1047. mac68k_alignment:
  1048. varalignrecord:=2;
  1049. else
  1050. varalignrecord:=field2recordalignment(fieldoffset,varalign);
  1051. end;
  1052. recordalignment:=max(recordalignment,varalignrecord);
  1053. end;
  1054. procedure tabstractrecordsymtable.addfield(sym:tfieldvarsym;vis:tvisibility);
  1055. var
  1056. l : asizeint;
  1057. varalign : shortint;
  1058. vardef : tdef;
  1059. begin
  1060. if (sym.owner<>self) then
  1061. internalerror(200602031);
  1062. if sym.fieldoffset<>-1 then
  1063. internalerror(200602032);
  1064. { set visibility for the symbol }
  1065. sym.visibility:=vis;
  1066. { this symbol can't be loaded to a register }
  1067. sym.varregable:=vr_none;
  1068. { Calculate field offset }
  1069. l:=sym.getsize;
  1070. vardef:=sym.vardef;
  1071. varalign:=vardef.structalignment;
  1072. case usefieldalignment of
  1073. bit_alignment:
  1074. begin
  1075. { bitpacking only happens for ordinals, the rest is aligned at }
  1076. { 1 byte (compatible with GPC/GCC) }
  1077. if is_ordinal(vardef) then
  1078. begin
  1079. sym.fieldoffset:=databitsize;
  1080. l:=sym.getpackedbitsize;
  1081. end
  1082. else
  1083. begin
  1084. databitsize:=_datasize*8;
  1085. sym.fieldoffset:=databitsize;
  1086. if (l>high(asizeint) div 8) then
  1087. Message(sym_e_segment_too_large);
  1088. l:=l*8;
  1089. end;
  1090. if varalign=0 then
  1091. varalign:=size_2_align(l);
  1092. recordalignment:=max(recordalignment,field2recordalignment(databitsize mod 8,varalign));
  1093. { bit packed records are limited to high(aint) bits }
  1094. { instead of bytes to avoid double precision }
  1095. { arithmetic in offset calculations }
  1096. if int64(l)>high(asizeint)-sym.fieldoffset then
  1097. begin
  1098. Message(sym_e_segment_too_large);
  1099. _datasize:=high(asizeint);
  1100. databitsize:=high(asizeint);
  1101. end
  1102. else
  1103. begin
  1104. databitsize:=sym.fieldoffset+l;
  1105. _datasize:=(databitsize+7) div 8;
  1106. end;
  1107. { rest is not applicable }
  1108. exit;
  1109. end;
  1110. else
  1111. begin
  1112. sym.fieldoffset:=getfieldoffset(sym,_datasize,fieldalignment);
  1113. if l>high(asizeint)-sym.fieldoffset then
  1114. begin
  1115. Message(sym_e_segment_too_large);
  1116. _datasize:=high(asizeint);
  1117. end
  1118. else
  1119. _datasize:=sym.fieldoffset+l;
  1120. { Calc alignment needed for this record }
  1121. alignrecord(sym.fieldoffset,varalign);
  1122. end;
  1123. end;
  1124. end;
  1125. function field_alignment_compare(item1, item2: pointer): integer;
  1126. var
  1127. field1: tfieldvarsym absolute item1;
  1128. field2: tfieldvarsym absolute item2;
  1129. begin
  1130. { we don't care about static fields, those become global variables }
  1131. if (sp_static in field1.symoptions) or
  1132. (sp_static in field2.symoptions) then
  1133. exit(0);
  1134. { sort from large to small alignment, and in case of the same alignment
  1135. in declaration order (items declared close together are possibly
  1136. also related and hence possibly used together -> putting them next
  1137. to each other can improve cache behaviour) }
  1138. result:=field2.vardef.alignment-field1.vardef.alignment;
  1139. if result=0 then
  1140. result:=field1.fieldoffset-field2.fieldoffset;
  1141. end;
  1142. procedure tabstractrecordsymtable.addfieldlist(list: tfpobjectlist; maybereorder: boolean);
  1143. var
  1144. fieldvs, insertfieldvs: tfieldvarsym;
  1145. base, fieldoffset, space, insertfieldsize, insertfieldoffset, bestinsertfieldoffset, bestspaceleft: asizeint;
  1146. i, j, bestfieldindex: longint;
  1147. globalfieldalignment,
  1148. prevglobalfieldalignment,
  1149. newfieldalignment: shortint;
  1150. changed: boolean;
  1151. begin
  1152. if maybereorder and
  1153. (cs_opt_reorder_fields in current_settings.optimizerswitches) then
  1154. begin
  1155. { assign dummy field offsets so we can know their order in the
  1156. sorting routine }
  1157. for i:=0 to list.count-1 do
  1158. tfieldvarsym(list[i]).fieldoffset:=i;
  1159. { sort the non-class fields to minimise losses due to alignment }
  1160. list.sort(@field_alignment_compare);
  1161. { now fill up gaps caused by alignment skips with smaller fields
  1162. where possible }
  1163. repeat
  1164. i:=0;
  1165. base:=_datasize;
  1166. globalfieldalignment:=fieldalignment;
  1167. changed:=false;
  1168. while i<list.count do
  1169. begin
  1170. fieldvs:=tfieldvarsym(list[i]);
  1171. if sp_static in fieldvs.symoptions then
  1172. begin
  1173. inc(i);
  1174. continue;
  1175. end;
  1176. prevglobalfieldalignment:=globalfieldalignment;
  1177. fieldoffset:=getfieldoffset(fieldvs,base,globalfieldalignment);
  1178. newfieldalignment:=globalfieldalignment;
  1179. { size of the gap between the end of the previous field and
  1180. the start of the current one }
  1181. space:=fieldoffset-base;
  1182. bestspaceleft:=space;
  1183. while space>0 do
  1184. begin
  1185. bestfieldindex:=-1;
  1186. bestinsertfieldoffset:=-1;
  1187. for j:=i+1 to list.count-1 do
  1188. begin
  1189. insertfieldvs:=tfieldvarsym(list[j]);
  1190. if sp_static in insertfieldvs.symoptions then
  1191. continue;
  1192. insertfieldsize:=insertfieldvs.getsize;
  1193. { can the new field fit possibly in the gap? }
  1194. if insertfieldsize<=space then
  1195. begin
  1196. { restore globalfieldalignment to situation before
  1197. the original field was inserted }
  1198. globalfieldalignment:=prevglobalfieldalignment;
  1199. { at what offset would it be inserted? (this new
  1200. field has its own alignment requirements, which
  1201. may make it impossible to fit after all) }
  1202. insertfieldoffset:=getfieldoffset(insertfieldvs,base,globalfieldalignment);
  1203. globalfieldalignment:=prevglobalfieldalignment;
  1204. { taking into account the alignment, does it still
  1205. fit and if so, does it fit better than the
  1206. previously found best fit? }
  1207. if (insertfieldoffset+insertfieldsize<=fieldoffset) and
  1208. (fieldoffset-insertfieldoffset-insertfieldsize<bestspaceleft) then
  1209. begin
  1210. { new best fit }
  1211. bestfieldindex:=j;
  1212. bestinsertfieldoffset:=insertfieldoffset;
  1213. bestspaceleft:=fieldoffset-insertfieldoffset-insertfieldsize;
  1214. if bestspaceleft=0 then
  1215. break;
  1216. end;
  1217. end;
  1218. end;
  1219. { if we didn't find any field to fit, stop trying for this
  1220. gap }
  1221. if bestfieldindex=-1 then
  1222. break;
  1223. changed:=true;
  1224. { we found a field to insert -> adjust the new base
  1225. address }
  1226. base:=bestinsertfieldoffset+tfieldvarsym(list[bestfieldindex]).getsize;
  1227. { update globalfieldalignment for this newly inserted
  1228. field }
  1229. getfieldoffset(tfieldvarsym(list[bestfieldindex]),base,globalfieldalignment);
  1230. { move the new field before the current one }
  1231. list.move(bestfieldindex,i);
  1232. { and skip the new field (which is now at position i) }
  1233. inc(i);
  1234. { there may be more space left -> continue }
  1235. space:=bestspaceleft;
  1236. end;
  1237. if base>fieldoffset then
  1238. internalerror(2012071302);
  1239. { check the next field }
  1240. base:=fieldoffset+fieldvs.getsize;
  1241. { since the original field had the same or greater alignment
  1242. than anything we inserted before it, the global field
  1243. alignment is still the same now as it was originally after
  1244. inserting that field }
  1245. globalfieldalignment:=newfieldalignment;
  1246. inc(i);
  1247. end;
  1248. { there may be small gaps left *before* inserted fields }
  1249. until not changed;
  1250. end;
  1251. { reset the dummy field offsets }
  1252. for i:=0 to list.count-1 do
  1253. tfieldvarsym(list[i]).fieldoffset:=-1;
  1254. { finally, set the actual field offsets }
  1255. for i:=0 to list.count-1 do
  1256. begin
  1257. fieldvs:=tfieldvarsym(list[i]);
  1258. { static data fields are already inserted in the globalsymtable }
  1259. if not(sp_static in fieldvs.symoptions) then
  1260. begin
  1261. { read_record_fields already set the visibility of the fields,
  1262. because a single list can contain symbols with different
  1263. visibility }
  1264. addfield(fieldvs,fieldvs.visibility);
  1265. end;
  1266. end;
  1267. end;
  1268. function tabstractrecordsymtable.findfieldbyoffset(offset: asizeint): tfieldvarsym;
  1269. var
  1270. i: longint;
  1271. sym: tsym;
  1272. begin
  1273. { there could be multiple fields in case of a variant record }
  1274. if (defowner.typ=recorddef) and
  1275. trecorddef(defowner).isunion then
  1276. internalerror(2014090403);
  1277. for i:=0 to SymList.count-1 do
  1278. begin
  1279. sym:=tsym(symlist[i]);
  1280. if (sym.typ=fieldvarsym) and
  1281. not(sp_static in sym.symoptions) and
  1282. (tfieldvarsym(sym).fieldoffset>=offset) then
  1283. begin
  1284. result:=tfieldvarsym(sym);
  1285. exit;
  1286. end;
  1287. end;
  1288. result:=nil;
  1289. end;
  1290. procedure tabstractrecordsymtable.addalignmentpadding;
  1291. var
  1292. padded_datasize: asizeint;
  1293. begin
  1294. { make the record size aligned correctly so it can be
  1295. used as elements in an array. For C records we
  1296. use the fieldalignment, because that is updated with the
  1297. used alignment. }
  1298. if (padalignment = 1) then
  1299. case usefieldalignment of
  1300. C_alignment:
  1301. padalignment:=fieldalignment;
  1302. { bitpacked }
  1303. bit_alignment:
  1304. padalignment:=1;
  1305. { mac68k: always round to multiple of 2 }
  1306. mac68k_alignment:
  1307. padalignment:=2;
  1308. { default/no packrecords specified }
  1309. 0:
  1310. padalignment:=recordalignment
  1311. { specific packrecords setting -> use as upper limit }
  1312. else
  1313. padalignment:=min(recordalignment,usefieldalignment);
  1314. end;
  1315. padded_datasize:=align(_datasize,padalignment);
  1316. _paddingsize:=padded_datasize-_datasize;
  1317. _datasize:=padded_datasize;
  1318. end;
  1319. procedure tabstractrecordsymtable.insertdef(def:TDefEntry);
  1320. begin
  1321. { Enums must also be available outside the record scope,
  1322. insert in the owner of this symtable }
  1323. if def.typ=enumdef then
  1324. defowner.owner.insertdef(def)
  1325. else
  1326. inherited insertdef(def);
  1327. end;
  1328. function tabstractrecordsymtable.is_packed: boolean;
  1329. begin
  1330. result:=usefieldalignment=bit_alignment;
  1331. end;
  1332. function tabstractrecordsymtable.has_single_field(out def:tdef): boolean;
  1333. var
  1334. i: longint;
  1335. currentsymlist: TFPHashObjectList;
  1336. currentdef: tdef;
  1337. sym: tfieldvarsym;
  1338. begin
  1339. result:=false;
  1340. { If a record contains a union, it does not contain a "single
  1341. non-composite field" in the context of certain ABIs requiring
  1342. special treatment for such records }
  1343. if (defowner.typ=recorddef) and
  1344. trecorddef(defowner).isunion then
  1345. exit;
  1346. { a record/object can contain other things than fields }
  1347. currentsymlist:=symlist;
  1348. { recurse in arrays and records }
  1349. sym:=nil;
  1350. repeat
  1351. { record has one field? }
  1352. for i:=0 to currentsymlist.Count-1 do
  1353. begin
  1354. if (tsym(currentsymlist[i]).typ=fieldvarsym) and
  1355. not(sp_static in tsym(currentsymlist[i]).symoptions) then
  1356. begin
  1357. if result then
  1358. begin
  1359. result:=false;
  1360. exit;
  1361. end;
  1362. result:=true;
  1363. sym:=tfieldvarsym(currentsymlist[i])
  1364. end;
  1365. end;
  1366. if assigned(sym) then
  1367. begin
  1368. { if the field is an array, does it contain one element? }
  1369. currentdef:=sym.vardef;
  1370. while (currentdef.typ=arraydef) and
  1371. not is_special_array(currentdef) do
  1372. begin
  1373. if tarraydef(currentdef).elecount<>1 then
  1374. begin
  1375. result:=false;
  1376. exit;
  1377. end;
  1378. currentdef:=tarraydef(currentdef).elementdef;
  1379. end;
  1380. { if the array element is again a record, continue descending }
  1381. if currentdef.typ=recorddef then
  1382. currentsymlist:=trecorddef(currentdef).symtable.SymList
  1383. else
  1384. begin
  1385. { otherwise we found the type of the single element }
  1386. def:=currentdef;
  1387. exit;
  1388. end;
  1389. end
  1390. else
  1391. exit
  1392. until false;
  1393. end;
  1394. function tabstractrecordsymtable.get_unit_symtable: tsymtable;
  1395. begin
  1396. result:=defowner.owner;
  1397. while assigned(result) and (result.symtabletype in [ObjectSymtable,recordsymtable]) do
  1398. result:=result.defowner.owner;
  1399. end;
  1400. procedure tabstractrecordsymtable.setdatasize(val: asizeint);
  1401. begin
  1402. _datasize:=val;
  1403. if (usefieldalignment=bit_alignment) then
  1404. { can overflow in non bitpacked records }
  1405. databitsize:=val*8;
  1406. end;
  1407. function tabstractrecordsymtable.getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint;
  1408. var
  1409. l : asizeint;
  1410. varalignfield,
  1411. varalign : shortint;
  1412. vardef : tdef;
  1413. begin
  1414. { Calculate field offset }
  1415. l:=sym.getsize;
  1416. vardef:=sym.vardef;
  1417. varalign:=vardef.structalignment;
  1418. case usefieldalignment of
  1419. bit_alignment:
  1420. { has to be handled separately }
  1421. internalerror(2012071301);
  1422. C_alignment:
  1423. begin
  1424. { Calc the alignment size for C style records }
  1425. if (varalign>4) and
  1426. ((varalign mod 4)<>0) and
  1427. (vardef.typ=arraydef) then
  1428. Message1(sym_w_wrong_C_pack,vardef.typename);
  1429. if varalign=0 then
  1430. varalign:=l;
  1431. if (globalfieldalignment<maxCrecordalign) then
  1432. begin
  1433. if (varalign>16) and (globalfieldalignment<32) then
  1434. globalfieldalignment:=32
  1435. else if (varalign>12) and (globalfieldalignment<16) then
  1436. globalfieldalignment:=16
  1437. { 12 is needed for long double }
  1438. else if (varalign>8) and (globalfieldalignment<12) then
  1439. globalfieldalignment:=12
  1440. else if (varalign>4) and (globalfieldalignment<8) then
  1441. globalfieldalignment:=8
  1442. else if (varalign>2) and (globalfieldalignment<4) then
  1443. globalfieldalignment:=4
  1444. else if (varalign>1) and (globalfieldalignment<2) then
  1445. globalfieldalignment:=2;
  1446. end;
  1447. globalfieldalignment:=min(globalfieldalignment,maxCrecordalign);
  1448. end;
  1449. mac68k_alignment:
  1450. begin
  1451. { mac68k alignment (C description):
  1452. * char is aligned to 1 byte
  1453. * everything else (except vector) is aligned to 2 bytes
  1454. * vector is aligned to 16 bytes
  1455. }
  1456. if l>1 then
  1457. globalfieldalignment:=2
  1458. else
  1459. globalfieldalignment:=1;
  1460. varalign:=2;
  1461. end;
  1462. end;
  1463. if varalign=0 then
  1464. varalign:=size_2_align(l);
  1465. varalignfield:=used_align(varalign,recordalignmin,globalfieldalignment);
  1466. result:=align(base,varalignfield);
  1467. end;
  1468. function tabstractrecordsymtable.iscurrentunit: boolean;
  1469. begin
  1470. Result:=assigned(current_module)and(current_module.moduleid=moduleid);
  1471. end;
  1472. {****************************************************************************
  1473. TRecordSymtable
  1474. ****************************************************************************}
  1475. constructor trecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  1476. begin
  1477. inherited create(n,usealign,recordminalign,recordmaxCalign);
  1478. symtabletype:=recordsymtable;
  1479. end;
  1480. { this procedure is reserved for inserting case variant into
  1481. a record symtable }
  1482. { the offset is the location of the start of the variant
  1483. and datasize and dataalignment corresponds to
  1484. the complete size (see code in pdecl unit) PM }
  1485. procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : longint);
  1486. var
  1487. sym : tsym;
  1488. def : tdef;
  1489. i : integer;
  1490. varalignrecord,varalign,
  1491. storesize,storealign : aint;
  1492. bitsize: tcgint;
  1493. begin
  1494. storesize:=_datasize;
  1495. storealign:=fieldalignment;
  1496. _datasize:=offset;
  1497. if (usefieldalignment=bit_alignment) then
  1498. databitsize:=offset*8;
  1499. { We move the ownership of the defs and symbols to the new recordsymtable.
  1500. The old unionsymtable keeps the references, but doesn't own the
  1501. objects anymore }
  1502. unionst.DefList.OwnsObjects:=false;
  1503. unionst.SymList.OwnsObjects:=false;
  1504. { copy symbols }
  1505. for i:=0 to unionst.SymList.Count-1 do
  1506. begin
  1507. sym:=TSym(unionst.SymList[i]);
  1508. if sym.typ<>fieldvarsym then
  1509. internalerror(200601272);
  1510. if tfieldvarsym(sym).fieldoffset=0 then
  1511. include(tfieldvarsym(sym).varoptions,vo_is_first_field);
  1512. { add to this record symtable, checking for duplicate names }
  1513. // unionst.SymList.List.List^[i].Data:=nil;
  1514. insert(sym);
  1515. varalign:=tfieldvarsym(sym).vardef.alignment;
  1516. if varalign=0 then
  1517. varalign:=size_2_align(tfieldvarsym(sym).getsize);
  1518. { retrieve size }
  1519. if (usefieldalignment=bit_alignment) then
  1520. begin
  1521. { bit packed records are limited to high(aint) bits }
  1522. { instead of bytes to avoid double precision }
  1523. { arithmetic in offset calculations }
  1524. if is_ordinal(tfieldvarsym(sym).vardef) then
  1525. bitsize:=tfieldvarsym(sym).getpackedbitsize
  1526. else
  1527. begin
  1528. bitsize:=tfieldvarsym(sym).getsize;
  1529. if (bitsize>high(asizeint) div 8) then
  1530. Message(sym_e_segment_too_large);
  1531. bitsize:=bitsize*8;
  1532. end;
  1533. if bitsize>high(asizeint)-databitsize then
  1534. begin
  1535. Message(sym_e_segment_too_large);
  1536. _datasize:=high(asizeint);
  1537. databitsize:=high(asizeint);
  1538. end
  1539. else
  1540. begin
  1541. databitsize:=tfieldvarsym(sym).fieldoffset+offset*8;
  1542. _datasize:=(databitsize+7) div 8;
  1543. end;
  1544. tfieldvarsym(sym).fieldoffset:=databitsize;
  1545. varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset div 8,varalign);
  1546. end
  1547. else
  1548. begin
  1549. if tfieldvarsym(sym).getsize>high(asizeint)-_datasize then
  1550. begin
  1551. Message(sym_e_segment_too_large);
  1552. _datasize:=high(asizeint);
  1553. end
  1554. else
  1555. _datasize:=tfieldvarsym(sym).fieldoffset+offset;
  1556. { update address }
  1557. tfieldvarsym(sym).fieldoffset:=_datasize;
  1558. varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset,varalign);
  1559. end;
  1560. { update alignment of this record }
  1561. if (usefieldalignment<>C_alignment) and
  1562. (usefieldalignment<>mac68k_alignment) then
  1563. recordalignment:=max(recordalignment,varalignrecord);
  1564. end;
  1565. { update alignment for C records }
  1566. if (usefieldalignment=C_alignment) and
  1567. (usefieldalignment<>mac68k_alignment) then
  1568. recordalignment:=max(recordalignment,unionst.recordalignment);
  1569. { Register defs in the new record symtable }
  1570. for i:=0 to unionst.DefList.Count-1 do
  1571. begin
  1572. def:=TDef(unionst.DefList[i]);
  1573. def.ChangeOwner(self);
  1574. end;
  1575. _datasize:=storesize;
  1576. fieldalignment:=storealign;
  1577. { If a record contains a union, it does not contain a "single
  1578. non-composite field" in the context of certain ABIs requiring
  1579. special treatment for such records }
  1580. if defowner.typ=recorddef then
  1581. trecorddef(defowner).isunion:=true;
  1582. end;
  1583. procedure trecordsymtable.includemanagementoperator(mop:tmanagementoperator);
  1584. begin
  1585. if mop in managementoperators then
  1586. exit;
  1587. include(managementoperators,mop);
  1588. end;
  1589. {****************************************************************************
  1590. TObjectSymtable
  1591. ****************************************************************************}
  1592. constructor tObjectSymtable.create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint);
  1593. begin
  1594. inherited create(n,usealign,recordminalign,recordmaxCalign);
  1595. symtabletype:=ObjectSymtable;
  1596. defowner:=adefowner;
  1597. end;
  1598. function tObjectSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1599. var
  1600. hsym: tsym;
  1601. warn: boolean;
  1602. begin
  1603. result:=false;
  1604. if not assigned(defowner) then
  1605. internalerror(200602061);
  1606. { procsym and propertysym have special code
  1607. to override values in inherited classes. For other
  1608. symbols check for duplicates }
  1609. if not(sym.typ in [procsym,propertysym]) then
  1610. begin
  1611. { but private ids can be reused }
  1612. hsym:=search_struct_member(tobjectdef(defowner),hashedid.id);
  1613. if assigned(hsym) and
  1614. (
  1615. (
  1616. not(m_delphi in current_settings.modeswitches) and
  1617. is_visible_for_object(hsym,tobjectdef(defowner))
  1618. ) or
  1619. (
  1620. { In Delphi, you can repeat members of a parent class. You can't }
  1621. { do this for objects however, and you (obviouly) can't }
  1622. { declare two fields with the same name in a single class }
  1623. (m_delphi in current_settings.modeswitches) and
  1624. (
  1625. is_object(tdef(defowner)) or
  1626. (hsym.owner = self)
  1627. )
  1628. )
  1629. ) then
  1630. begin
  1631. { only watn when a parameter/local variable in a method
  1632. conflicts with a category method, because this can easily
  1633. happen due to all possible categories being imported via
  1634. CocoaAll }
  1635. warn:=
  1636. (is_objccategory(tdef(hsym.owner.defowner)) or
  1637. is_classhelper(tdef(hsym.owner.defowner))) and
  1638. (sym.typ in [paravarsym,localvarsym,fieldvarsym]);
  1639. DuplicateSym(hashedid,sym,hsym,warn);
  1640. result:=true;
  1641. end;
  1642. end
  1643. else
  1644. result:=inherited checkduplicate(hashedid,sym);
  1645. end;
  1646. {$ifdef llvm}
  1647. {****************************************************************************
  1648. tLlvmShadowSymtableEntry
  1649. ****************************************************************************}
  1650. constructor tllvmshadowsymtableentry.create(def: tdef; fieldoffset: aint);
  1651. begin
  1652. fdef:=def;
  1653. ffieldoffset:=fieldoffset;
  1654. end;
  1655. {****************************************************************************
  1656. TLlvmShadowSymtable
  1657. ****************************************************************************}
  1658. function tllvmshadowsymtable.get(f: tfieldvarsym): tllvmshadowsymtableentry;
  1659. begin
  1660. result:=get_by_llvm_index(f.llvmfieldnr)
  1661. end;
  1662. function tllvmshadowsymtable.get_by_llvm_index(index: longint): tllvmshadowsymtableentry;
  1663. begin
  1664. result:=tllvmshadowsymtableentry(symdeflist[index]);
  1665. end;
  1666. constructor tllvmshadowsymtable.create(st: tabstractrecordsymtable);
  1667. begin
  1668. equivst:=st;
  1669. curroffset:=0;
  1670. symdeflist:=tfpobjectlist.create(true);
  1671. generate;
  1672. end;
  1673. destructor tllvmshadowsymtable.destroy;
  1674. begin
  1675. symdeflist.free;
  1676. end;
  1677. procedure tllvmshadowsymtable.appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean);
  1678. var
  1679. sizectr,
  1680. tmpsize: aint;
  1681. begin
  1682. case equivst.usefieldalignment of
  1683. bit_alignment:
  1684. begin
  1685. { curoffset: bit address after the previous field. }
  1686. { llvm has no special support for bitfields in records, }
  1687. { so we replace them with plain bytes. }
  1688. { as soon as a single bit of a byte is allocated, we }
  1689. { allocate the byte in the llvm shadow record }
  1690. if (fieldoffset>curroffset) then
  1691. curroffset:=align(curroffset,8);
  1692. { fields in bitpacked records always start either right }
  1693. { after the previous one, or at the next byte boundary. }
  1694. if (curroffset<>fieldoffset) then
  1695. internalerror(2008051002);
  1696. if is_ordinal(vardef) then
  1697. begin
  1698. tmpsize:=vardef.packedbitsize;
  1699. sizectr:=((curroffset+tmpsize+7) shr 3)-((curroffset+7) shr 3);
  1700. inc(curroffset,tmpsize);
  1701. tmpsize:=0;
  1702. while sizectr<>0 do
  1703. begin
  1704. symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,fieldoffset+tmpsize*8));
  1705. dec(sizectr);
  1706. inc(tmpsize);
  1707. end;
  1708. end
  1709. else
  1710. begin
  1711. symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
  1712. if not(derefclass) then
  1713. inc(curroffset,vardef.size*8)
  1714. else
  1715. inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize*8);
  1716. end;
  1717. end
  1718. else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then
  1719. begin
  1720. { curoffset: address right after the previous field }
  1721. while (fieldoffset>curroffset) do
  1722. begin
  1723. symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset));
  1724. inc(curroffset);
  1725. end;
  1726. symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
  1727. if not(derefclass) then
  1728. inc(curroffset,vardef.size)
  1729. else
  1730. inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize);
  1731. end
  1732. else
  1733. { default for llvm, don't add explicit padding }
  1734. symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
  1735. end
  1736. end;
  1737. procedure tllvmshadowsymtable.addalignmentpadding(finalsize: aint);
  1738. begin
  1739. case equivst.usefieldalignment of
  1740. { already correct in this case }
  1741. bit_alignment:
  1742. ;
  1743. else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then
  1744. begin
  1745. { add padding fields }
  1746. while (finalsize>curroffset) do
  1747. begin
  1748. symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset));
  1749. inc(curroffset);
  1750. end;
  1751. end;
  1752. end;
  1753. end;
  1754. procedure tllvmshadowsymtable.findvariantstarts(variantstarts: tfplist);
  1755. var
  1756. sym: tfieldvarsym;
  1757. lastoffset: aint;
  1758. newalignment: aint;
  1759. i, j: longint;
  1760. begin
  1761. i:=0;
  1762. while (i<equivst.symlist.count) do
  1763. begin
  1764. if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
  1765. (sp_static in tsym(equivst.symlist[i]).symoptions) then
  1766. begin
  1767. inc(i);
  1768. continue;
  1769. end;
  1770. sym:=tfieldvarsym(equivst.symlist[i]);
  1771. { a "better" algorithm might be to use the largest }
  1772. { variant in case of (bit)packing, since then }
  1773. { alignment doesn't matter }
  1774. if (vo_is_first_field in sym.varoptions) then
  1775. begin
  1776. { we assume that all fields are processed in order. }
  1777. if (variantstarts.count<>0) then
  1778. lastoffset:=tfieldvarsym(variantstarts[variantstarts.count-1]).fieldoffset
  1779. else
  1780. lastoffset:=-1;
  1781. { new variant at same level as last one: use if higher alignment }
  1782. if (lastoffset=sym.fieldoffset) then
  1783. begin
  1784. if (equivst.fieldalignment<>bit_alignment) then
  1785. newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment)
  1786. else
  1787. newalignment:=1;
  1788. if (newalignment>tfieldvarsym(variantstarts[variantstarts.count-1]).vardef.alignment) then
  1789. variantstarts[variantstarts.count-1]:=sym;
  1790. end
  1791. { variant at deeper level than last one -> add }
  1792. else if (lastoffset<sym.fieldoffset) then
  1793. variantstarts.add(sym)
  1794. else
  1795. begin
  1796. { a variant at a less deep level, so backtrack }
  1797. j:=variantstarts.count-2;
  1798. while (j>=0) do
  1799. begin
  1800. if (tfieldvarsym(variantstarts[j]).fieldoffset=sym.fieldoffset) then
  1801. break;
  1802. dec(j);
  1803. end;
  1804. if (j<0) then
  1805. internalerror(2008051003);
  1806. { new variant has higher alignment? }
  1807. if (equivst.fieldalignment<>bit_alignment) then
  1808. newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment)
  1809. else
  1810. newalignment:=1;
  1811. { yes, replace and remove previous nested variants }
  1812. if (newalignment>tfieldvarsym(variantstarts[j]).vardef.alignment) then
  1813. begin
  1814. variantstarts[j]:=sym;
  1815. variantstarts.count:=j+1;
  1816. end
  1817. { no, skip this variant }
  1818. else
  1819. begin
  1820. inc(i);
  1821. while (i<equivst.symlist.count) and
  1822. ((tsym(equivst.symlist[i]).typ<>fieldvarsym) or
  1823. (sp_static in tsym(equivst.symlist[i]).symoptions) or
  1824. (tfieldvarsym(equivst.symlist[i]).fieldoffset>sym.fieldoffset)) do
  1825. inc(i);
  1826. continue;
  1827. end;
  1828. end;
  1829. end;
  1830. inc(i);
  1831. end;
  1832. end;
  1833. procedure tllvmshadowsymtable.buildtable(variantstarts: tfplist);
  1834. var
  1835. lastvaroffsetprocessed: aint;
  1836. i, equivcount, varcount: longint;
  1837. begin
  1838. { if it's an object/class, the first entry is the parent (if there is one) }
  1839. if (equivst.symtabletype=objectsymtable) and
  1840. assigned(tobjectdef(equivst.defowner).childof) then
  1841. appenddefoffset(tobjectdef(equivst.defowner).childof,0,is_class_or_interface_or_dispinterface(tobjectdef(equivst.defowner).childof));
  1842. equivcount:=equivst.symlist.count;
  1843. varcount:=0;
  1844. i:=0;
  1845. lastvaroffsetprocessed:=-1;
  1846. while (i<equivcount) do
  1847. begin
  1848. if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
  1849. (sp_static in tsym(equivst.symlist[i]).symoptions) then
  1850. begin
  1851. inc(i);
  1852. continue;
  1853. end;
  1854. { start of a new variant? }
  1855. if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then
  1856. begin
  1857. { if we want to process the same variant offset twice, it means that we }
  1858. { got to the end and are trying to process the next variant part -> stop }
  1859. if (tfieldvarsym(equivst.symlist[i]).fieldoffset<=lastvaroffsetprocessed) then
  1860. break;
  1861. if (varcount>=variantstarts.count) then
  1862. internalerror(2008051005);
  1863. { new variant part -> use the one with the biggest alignment }
  1864. i:=equivst.symlist.indexof(tobject(variantstarts[varcount]));
  1865. lastvaroffsetprocessed:=tfieldvarsym(equivst.symlist[i]).fieldoffset;
  1866. inc(varcount);
  1867. if (i<0) then
  1868. internalerror(2008051004);
  1869. end;
  1870. appenddefoffset(tfieldvarsym(equivst.symlist[i]).vardef,tfieldvarsym(equivst.symlist[i]).fieldoffset,false);
  1871. inc(i);
  1872. end;
  1873. addalignmentpadding(equivst.datasize);
  1874. end;
  1875. procedure tllvmshadowsymtable.buildmapping(variantstarts: tfplist);
  1876. var
  1877. i, varcount: longint;
  1878. shadowindex: longint;
  1879. equivcount : longint;
  1880. begin
  1881. varcount:=0;
  1882. shadowindex:=0;
  1883. equivcount:=equivst.symlist.count;
  1884. i:=0;
  1885. while (i < equivcount) do
  1886. begin
  1887. if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
  1888. (sp_static in tsym(equivst.symlist[i]).symoptions) then
  1889. begin
  1890. inc(i);
  1891. continue;
  1892. end;
  1893. { start of a new variant? }
  1894. if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then
  1895. begin
  1896. { back up to a less deeply nested variant level? }
  1897. while (tfieldvarsym(equivst.symlist[i]).fieldoffset<tfieldvarsym(variantstarts[varcount]).fieldoffset) do
  1898. dec(varcount);
  1899. { it's possible that some variants are more deeply nested than the
  1900. one we recorded in the shadowsymtable (since we recorded the one
  1901. with the biggest alignment, not necessarily the biggest one in size
  1902. }
  1903. if (tfieldvarsym(equivst.symlist[i]).fieldoffset>tfieldvarsym(variantstarts[varcount]).fieldoffset) then
  1904. varcount:=variantstarts.count-1
  1905. else if (tfieldvarsym(equivst.symlist[i]).fieldoffset<>tfieldvarsym(variantstarts[varcount]).fieldoffset) then
  1906. internalerror(2008051006);
  1907. { reset the shadowindex to the start of this variant. }
  1908. { in case the llvmfieldnr is not (yet) set for this }
  1909. { field, shadowindex will simply be reset to zero and }
  1910. { we'll start searching from the start of the record }
  1911. shadowindex:=tfieldvarsym(variantstarts[varcount]).llvmfieldnr;
  1912. if (varcount<pred(variantstarts.count)) then
  1913. inc(varcount);
  1914. end;
  1915. { find the last shadowfield whose offset <= the current field's offset }
  1916. while (tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset<tfieldvarsym(equivst.symlist[i]).fieldoffset) and
  1917. (shadowindex<symdeflist.count-1) and
  1918. (tllvmshadowsymtableentry(symdeflist[shadowindex+1]).fieldoffset<=tfieldvarsym(equivst.symlist[i]).fieldoffset) do
  1919. inc(shadowindex);
  1920. { set the field number and potential offset from that field (in case }
  1921. { of overlapping variants) }
  1922. tfieldvarsym(equivst.symlist[i]).llvmfieldnr:=shadowindex;
  1923. tfieldvarsym(equivst.symlist[i]).offsetfromllvmfield:=
  1924. tfieldvarsym(equivst.symlist[i]).fieldoffset-tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset;
  1925. inc(i);
  1926. end;
  1927. end;
  1928. procedure tllvmshadowsymtable.generate;
  1929. var
  1930. variantstarts: tfplist;
  1931. begin
  1932. variantstarts:=tfplist.create;
  1933. { first go through the entire record and }
  1934. { store the fieldvarsyms of the variants }
  1935. { with the highest alignment }
  1936. findvariantstarts(variantstarts);
  1937. { now go through the regular fields and the selected variants, }
  1938. { and add them to the llvm shadow record symtable }
  1939. buildtable(variantstarts);
  1940. { finally map all original fields to the llvm definition }
  1941. buildmapping(variantstarts);
  1942. variantstarts.free;
  1943. end;
  1944. {$endif llvm}
  1945. {****************************************************************************
  1946. TAbstractSubSymtable
  1947. ****************************************************************************}
  1948. procedure tabstractsubsymtable.ppuwrite(ppufile:tcompilerppufile);
  1949. var
  1950. oldtyp : byte;
  1951. begin
  1952. oldtyp:=ppufile.entrytyp;
  1953. ppufile.entrytyp:=subentryid;
  1954. inherited ppuwrite(ppufile);
  1955. ppufile.entrytyp:=oldtyp;
  1956. end;
  1957. {****************************************************************************
  1958. TAbstractLocalSymtable
  1959. ****************************************************************************}
  1960. function tabstractlocalsymtable.count_locals:longint;
  1961. var
  1962. i : longint;
  1963. sym : tsym;
  1964. begin
  1965. result:=0;
  1966. for i:=0 to SymList.Count-1 do
  1967. begin
  1968. sym:=tsym(SymList[i]);
  1969. { Count only varsyms, but ignore the funcretsym }
  1970. if (tsym(sym).typ in [localvarsym,paravarsym]) and
  1971. (tsym(sym)<>current_procinfo.procdef.funcretsym) and
  1972. (not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or
  1973. (tstoredsym(sym).refs>0)) then
  1974. inc(result);
  1975. end;
  1976. end;
  1977. function tabstractlocalsymtable.iscurrentunit: boolean;
  1978. begin
  1979. Result:=
  1980. assigned(defowner) and
  1981. defowner.owner.iscurrentunit;
  1982. end;
  1983. {****************************************************************************
  1984. TLocalSymtable
  1985. ****************************************************************************}
  1986. constructor tlocalsymtable.create(adefowner:tdef;level:byte);
  1987. begin
  1988. inherited create('');
  1989. defowner:=adefowner;
  1990. symtabletype:=localsymtable;
  1991. symtablelevel:=level;
  1992. end;
  1993. function tlocalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1994. var
  1995. hsym : tsym;
  1996. begin
  1997. if not assigned(defowner) or
  1998. (defowner.typ<>procdef) then
  1999. internalerror(200602042);
  2000. result:=false;
  2001. hsym:=tsym(FindWithHash(hashedid));
  2002. if assigned(hsym) then
  2003. begin
  2004. { a local and the function can have the same
  2005. name in TP and Delphi, but RESULT not }
  2006. if (m_duplicate_names in current_settings.modeswitches) and
  2007. (hsym.typ in [absolutevarsym,localvarsym]) and
  2008. (vo_is_funcret in tabstractvarsym(hsym).varoptions) and
  2009. not((m_result in current_settings.modeswitches) and
  2010. (vo_is_result in tabstractvarsym(hsym).varoptions)) then
  2011. HideSym(hsym)
  2012. else
  2013. DuplicateSym(hashedid,sym,hsym,false);
  2014. result:=true;
  2015. exit;
  2016. end;
  2017. { check also parasymtable, this needs to be done here because
  2018. of the special situation with the funcret sym that needs to be
  2019. hidden for tp and delphi modes }
  2020. hsym:=tsym(tabstractprocdef(defowner).parast.FindWithHash(hashedid));
  2021. if assigned(hsym) then
  2022. begin
  2023. { a local and the function can have the same
  2024. name in TP and Delphi, but RESULT not }
  2025. if (m_duplicate_names in current_settings.modeswitches) and
  2026. (sym.typ in [absolutevarsym,localvarsym]) and
  2027. (vo_is_funcret in tabstractvarsym(sym).varoptions) and
  2028. not((m_result in current_settings.modeswitches) and
  2029. (vo_is_result in tabstractvarsym(sym).varoptions)) then
  2030. Hidesym(sym)
  2031. else
  2032. DuplicateSym(hashedid,sym,hsym,false);
  2033. result:=true;
  2034. exit;
  2035. end;
  2036. { check ObjectSymtable, skip this for funcret sym because
  2037. that will always be positive because it has the same name
  2038. as the procsym }
  2039. if not is_funcret_sym(sym) and
  2040. (defowner.typ=procdef) and
  2041. assigned(tprocdef(defowner).struct) and
  2042. (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
  2043. (
  2044. not(m_delphi in current_settings.modeswitches) or
  2045. is_object(tprocdef(defowner).struct)
  2046. ) then
  2047. result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
  2048. end;
  2049. {****************************************************************************
  2050. TParaSymtable
  2051. ****************************************************************************}
  2052. constructor tparasymtable.create(adefowner:tdef;level:byte);
  2053. begin
  2054. inherited create('');
  2055. readonly:=false;
  2056. defowner:=adefowner;
  2057. symtabletype:=parasymtable;
  2058. symtablelevel:=level;
  2059. end;
  2060. function tparasymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  2061. begin
  2062. result:=inherited checkduplicate(hashedid,sym);
  2063. if result then
  2064. exit;
  2065. if not(m_duplicate_names in current_settings.modeswitches) and
  2066. assigned(defowner) and (defowner.typ=procdef) and
  2067. assigned(tprocdef(defowner).struct) and
  2068. assigned(tprocdef(defowner).owner) and
  2069. (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
  2070. (
  2071. not(m_delphi in current_settings.modeswitches) or
  2072. is_object(tprocdef(defowner).struct)
  2073. ) then
  2074. result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
  2075. end;
  2076. procedure tparasymtable.insertdef(def: TDefEntry);
  2077. begin
  2078. if readonly then
  2079. defowner.owner.insertdef(def)
  2080. else
  2081. inherited insertdef(def);
  2082. end;
  2083. {****************************************************************************
  2084. TAbstractUniTSymtable
  2085. ****************************************************************************}
  2086. constructor tabstractuniTSymtable.create(const n : string;id:word);
  2087. begin
  2088. inherited create(n);
  2089. moduleid:=id;
  2090. end;
  2091. function tabstractuniTSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  2092. var
  2093. hsym : tsym;
  2094. begin
  2095. result:=false;
  2096. hsym:=tsym(FindWithHash(hashedid));
  2097. if assigned(hsym) then
  2098. begin
  2099. if (sym is tstoredsym) and handle_generic_dummysym(hsym,tstoredsym(sym).symoptions) then
  2100. exit;
  2101. if hsym.typ=symconst.namespacesym then
  2102. begin
  2103. case sym.typ of
  2104. symconst.namespacesym:;
  2105. symconst.unitsym:
  2106. begin
  2107. HideSym(sym); { if we add a unit and there is a namespace with the same name then hide the unit name and not the namespace }
  2108. tnamespacesym(hsym).unitsym:=tsym(sym);
  2109. end
  2110. else
  2111. HideSym(hsym);
  2112. end;
  2113. end
  2114. else
  2115. { In delphi (contrary to TP) you can have a symbol with the same name as the
  2116. unit, the unit can then not be accessed anymore using
  2117. <unit>.<id>, so we can hide the symbol.
  2118. Do the same if we add a namespace and there is a unit with the same name }
  2119. if (hsym.typ=symconst.unitsym) and
  2120. ((m_delphi in current_settings.modeswitches) or (sym.typ=symconst.namespacesym)) then
  2121. begin
  2122. HideSym(hsym);
  2123. if sym.typ=symconst.namespacesym then
  2124. tnamespacesym(sym).unitsym:=tsym(hsym);
  2125. end
  2126. { iso mode program parameters: staticvarsyms might have the same name as a program parameters,
  2127. in this case, copy the isoindex and make the original symbol invisible }
  2128. else if (m_isolike_program_para in current_settings.modeswitches) and (hsym.typ=programparasym) and (sym.typ=staticvarsym)
  2129. and (tprogramparasym(hsym).isoindex<>0) then
  2130. begin
  2131. HideSym(hsym);
  2132. tstaticvarsym(sym).isoindex:=tprogramparasym(hsym).isoindex;
  2133. end
  2134. else
  2135. DuplicateSym(hashedid,sym,hsym,false);
  2136. result:=true;
  2137. exit;
  2138. end;
  2139. end;
  2140. function tabstractuniTSymtable.findnamespace(const n:string):TSymEntry;
  2141. begin
  2142. result:=find(n);
  2143. if assigned(result)and(result.typ<>namespacesym)then
  2144. result:=nil;
  2145. end;
  2146. function tabstractuniTSymtable.iscurrentunit:boolean;
  2147. begin
  2148. result:=assigned(current_module) and
  2149. (
  2150. (current_module.globalsymtable=self) or
  2151. (current_module.localsymtable=self)
  2152. );
  2153. end;
  2154. procedure tabstractuniTSymtable.insertunit(sym:TSymEntry);
  2155. var
  2156. p:integer;
  2157. n,ns:string;
  2158. oldsym:TSymEntry;
  2159. begin
  2160. insert(sym);
  2161. n:=sym.realname;
  2162. p:=pos('.',n);
  2163. ns:='';
  2164. while p>0 do
  2165. begin
  2166. if ns='' then
  2167. ns:=copy(n,1,p-1)
  2168. else
  2169. ns:=ns+'.'+copy(n,1,p-1);
  2170. system.delete(n,1,p);
  2171. oldsym:=findnamespace(upper(ns));
  2172. if not assigned(oldsym) then
  2173. insert(cnamespacesym.create(ns));
  2174. p:=pos('.',n);
  2175. end;
  2176. end;
  2177. {****************************************************************************
  2178. TStaticSymtable
  2179. ****************************************************************************}
  2180. constructor tstaticsymtable.create(const n : string;id:word);
  2181. begin
  2182. inherited create(n,id);
  2183. symtabletype:=staticsymtable;
  2184. symtablelevel:=main_program_level;
  2185. currentvisibility:=vis_private;
  2186. end;
  2187. procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile);
  2188. begin
  2189. inherited ppuload(ppufile);
  2190. { now we can deref the syms and defs }
  2191. deref(false);
  2192. end;
  2193. procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile);
  2194. begin
  2195. inherited ppuwrite(ppufile);
  2196. end;
  2197. function tstaticsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  2198. begin
  2199. result:=inherited checkduplicate(hashedid,sym);
  2200. if not result and
  2201. (current_module.localsymtable=self) and
  2202. assigned(current_module.globalsymtable) then
  2203. result:=tglobalsymtable(current_module.globalsymtable).checkduplicate(hashedid,sym);
  2204. end;
  2205. function tstaticsymtable.findnamespace(const n:string):TSymEntry;
  2206. begin
  2207. result:=inherited findnamespace(n);
  2208. if not assigned(result) and
  2209. (current_module.localsymtable=self) and
  2210. assigned(current_module.globalsymtable) then
  2211. result:=tglobalsymtable(current_module.globalsymtable).findnamespace(n);
  2212. end;
  2213. {****************************************************************************
  2214. TGlobalSymtable
  2215. ****************************************************************************}
  2216. constructor tglobalsymtable.create(const n : string;id:word);
  2217. begin
  2218. inherited create(n,id);
  2219. symtabletype:=globalsymtable;
  2220. symtablelevel:=main_program_level;
  2221. end;
  2222. procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile);
  2223. begin
  2224. inherited ppuload(ppufile);
  2225. { now we can deref the syms and defs }
  2226. deref(false);
  2227. end;
  2228. procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile);
  2229. begin
  2230. { write the symtable entries }
  2231. inherited ppuwrite(ppufile);
  2232. end;
  2233. {*****************************************************************************
  2234. tspecializesymtable
  2235. *****************************************************************************}
  2236. constructor tspecializesymtable.create(const n : string;id:word);
  2237. begin
  2238. inherited create(n,id);
  2239. { the specialize symtable does not own the syms and defs as they are all
  2240. moved to a different symtable before the symtable is destroyed; this
  2241. avoids calls to "extract" }
  2242. symlist.ownsobjects:=false;
  2243. deflist.ownsobjects:=false;
  2244. end;
  2245. function tspecializesymtable.iscurrentunit: boolean;
  2246. begin
  2247. Result:=true;
  2248. end;
  2249. {****************************************************************************
  2250. TWITHSYMTABLE
  2251. ****************************************************************************}
  2252. constructor twithsymtable.create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
  2253. begin
  2254. inherited create('');
  2255. symtabletype:=withsymtable;
  2256. withrefnode:=refnode;
  2257. { Replace SymList with the passed symlist }
  2258. SymList.free;
  2259. SymList:=ASymList;
  2260. defowner:=aowner;
  2261. end;
  2262. destructor twithsymtable.destroy;
  2263. begin
  2264. withrefnode.free;
  2265. { Disable SymList because we don't Own it }
  2266. SymList:=nil;
  2267. inherited destroy;
  2268. end;
  2269. procedure twithsymtable.clear;
  2270. begin
  2271. { remove no entry from a withsymtable as it is only a pointer to the
  2272. recorddef or objectdef symtable }
  2273. end;
  2274. procedure twithsymtable.insertdef(def:TDefEntry);
  2275. begin
  2276. { Definitions can't be registered in the withsymtable
  2277. because the withsymtable is removed after the with block.
  2278. We can't easily solve it here because the next symtable in the
  2279. stack is not known. }
  2280. internalerror(200602046);
  2281. end;
  2282. {****************************************************************************
  2283. TSTT_ExceptionSymtable
  2284. ****************************************************************************}
  2285. constructor tstt_excepTSymtable.create;
  2286. begin
  2287. inherited create('');
  2288. symtabletype:=stt_excepTSymtable;
  2289. end;
  2290. {****************************************************************************
  2291. TMacroSymtable
  2292. ****************************************************************************}
  2293. constructor tmacrosymtable.create(exported: boolean);
  2294. begin
  2295. inherited create('');
  2296. if exported then
  2297. symtabletype:=exportedmacrosymtable
  2298. else
  2299. symtabletype:=localmacrosymtable;
  2300. symtablelevel:=main_program_level;
  2301. end;
  2302. {****************************************************************************
  2303. TEnumSymtable
  2304. ****************************************************************************}
  2305. procedure tenumsymtable.insert(sym: TSymEntry; checkdup: boolean);
  2306. var
  2307. value: longint;
  2308. def: tenumdef;
  2309. begin
  2310. // defowner = nil only when we are loading from ppu
  2311. if defowner<>nil then
  2312. begin
  2313. { First entry? Then we need to set the minval }
  2314. value:=tenumsym(sym).value;
  2315. def:=tenumdef(defowner);
  2316. if SymList.count=0 then
  2317. begin
  2318. if value>0 then
  2319. def.has_jumps:=true;
  2320. def.setmin(value);
  2321. def.setmax(value);
  2322. end
  2323. else
  2324. begin
  2325. { check for jumps }
  2326. if value>def.max+1 then
  2327. def.has_jumps:=true;
  2328. { update low and high }
  2329. if def.min>value then
  2330. def.setmin(value);
  2331. if def.max<value then
  2332. def.setmax(value);
  2333. end;
  2334. end;
  2335. inherited insert(sym, checkdup);
  2336. end;
  2337. constructor tenumsymtable.create(adefowner: tdef);
  2338. begin
  2339. inherited Create('');
  2340. symtabletype:=enumsymtable;
  2341. defowner:=adefowner;
  2342. end;
  2343. {****************************************************************************
  2344. TArraySymtable
  2345. ****************************************************************************}
  2346. procedure tarraysymtable.insertdef(def: TDefEntry);
  2347. begin
  2348. { Enums must also be available outside the record scope,
  2349. insert in the owner of this symtable }
  2350. if def.typ=enumdef then
  2351. defowner.owner.insertdef(def)
  2352. else
  2353. inherited insertdef(def);
  2354. end;
  2355. constructor tarraysymtable.create(adefowner: tdef);
  2356. begin
  2357. inherited Create('');
  2358. symtabletype:=arraysymtable;
  2359. defowner:=adefowner;
  2360. end;
  2361. {*****************************************************************************
  2362. Helper Routines
  2363. *****************************************************************************}
  2364. function FullTypeName(def,otherdef:tdef):string;
  2365. var
  2366. s1,s2 : string;
  2367. begin
  2368. if def.typ in [objectdef,recorddef] then
  2369. s1:=tabstractrecorddef(def).RttiName
  2370. else
  2371. s1:=def.typename;
  2372. { When the names are the same try to include the unit name }
  2373. if assigned(otherdef) and
  2374. (def.owner.symtabletype in [globalsymtable,staticsymtable]) then
  2375. begin
  2376. s2:=otherdef.typename;
  2377. if upper(s1)=upper(s2) then
  2378. s1:=def.owner.realname^+'.'+s1;
  2379. end;
  2380. FullTypeName:=s1;
  2381. end;
  2382. function generate_nested_name(symtable:tsymtable;delimiter:string):string;
  2383. begin
  2384. result:='';
  2385. while assigned(symtable) and (symtable.symtabletype in [ObjectSymtable,recordsymtable]) do
  2386. begin
  2387. if (result='') then
  2388. if symtable.name<>nil then
  2389. result:=symtable.name^
  2390. else
  2391. else
  2392. if symtable.name<>nil then
  2393. result:=symtable.name^+delimiter+result
  2394. else
  2395. result:=delimiter+result;
  2396. symtable:=symtable.defowner.owner;
  2397. end;
  2398. end;
  2399. function generate_objectpascal_helper_key(def:tdef):string;
  2400. begin
  2401. if not assigned(def) then
  2402. internalerror(2013020501);
  2403. if def.typ in [recorddef,objectdef] then
  2404. result:=make_mangledname('',tabstractrecorddef(def).symtable,'')
  2405. else
  2406. result:=make_mangledname('',def.owner,def.typesym.name);
  2407. end;
  2408. procedure incompatibletypes(def1,def2:tdef);
  2409. begin
  2410. { When there is an errordef there is already an error message show }
  2411. if (def2.typ=errordef) or
  2412. (def1.typ=errordef) then
  2413. exit;
  2414. CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
  2415. end;
  2416. procedure hidesym(sym:TSymEntry);
  2417. begin
  2418. sym.realname:='$hidden'+sym.realname;
  2419. tsym(sym).visibility:=vis_hidden;
  2420. end;
  2421. procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym: TSymEntry; warn: boolean);
  2422. var
  2423. st : TSymtable;
  2424. filename : TIDString;
  2425. begin
  2426. if not warn then
  2427. Message1(sym_e_duplicate_id,tsym(origsym).realname)
  2428. else
  2429. Message1(sym_w_duplicate_id,tsym(origsym).realname);
  2430. { Write hint where the original symbol was found }
  2431. st:=finduniTSymtable(origsym.owner);
  2432. with tsym(origsym).fileinfo do
  2433. begin
  2434. if assigned(st) and
  2435. (st.symtabletype=globalsymtable) and
  2436. st.iscurrentunit then
  2437. Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line))
  2438. else if assigned(st.name) then
  2439. begin
  2440. filename:=find_module_from_symtable(st).sourcefiles.get_file_name(fileindex);
  2441. if filename<>'' then
  2442. Message2(sym_h_duplicate_id_where,'unit '+st.name^+': '+filename,tostr(line))
  2443. else
  2444. Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line))
  2445. end;
  2446. end;
  2447. { Rename duplicate sym to an unreachable name, but it can be
  2448. inserted in the symtable without errors }
  2449. inc(dupnr);
  2450. hashedid.id:='dup'+tostr(dupnr)+hashedid.id;
  2451. if assigned(dupsym) then
  2452. include(tsym(dupsym).symoptions,sp_implicitrename);
  2453. end;
  2454. function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean;
  2455. begin
  2456. result:=false;
  2457. if not assigned(sym) or not (sym is tstoredsym) then
  2458. Internalerror(2011081101);
  2459. { For generics a dummy symbol without the parameter count is created
  2460. if such a symbol not yet exists so that different parts of the
  2461. parser can find that symbol. If that symbol is still a
  2462. undefineddef we replace the generic dummy symbol's
  2463. name with a "dup" name and use the new symbol as the generic dummy
  2464. symbol }
  2465. if (sp_generic_dummy in tstoredsym(sym).symoptions) and
  2466. (sym.typ=typesym) and (ttypesym(sym).typedef.typ=undefineddef) and
  2467. (m_delphi in current_settings.modeswitches) then
  2468. begin
  2469. inc(dupnr);
  2470. sym.Owner.SymList.Rename(upper(sym.realname),'dup_'+tostr(dupnr)+sym.realname);
  2471. include(tsym(sym).symoptions,sp_implicitrename);
  2472. { we need to find the new symbol now if checking for a dummy }
  2473. include(symoptions,sp_generic_dummy);
  2474. result:=true;
  2475. end;
  2476. end;
  2477. procedure write_system_parameter_lists(const name:string);
  2478. var
  2479. srsym:tprocsym;
  2480. begin
  2481. srsym:=tprocsym(systemunit.find(name));
  2482. if not assigned(srsym) or not (srsym.typ=procsym) then
  2483. internalerror(2016060302);
  2484. srsym.write_parameter_lists(nil);
  2485. end;
  2486. {*****************************************************************************
  2487. Search
  2488. *****************************************************************************}
  2489. procedure addsymref(sym:tsym);
  2490. var
  2491. owner: tsymtable;
  2492. begin
  2493. { symbol uses count }
  2494. sym.IncRefCount;
  2495. owner:=sym.owner;
  2496. while owner.symtabletype in [objectsymtable,recordsymtable,enumsymtable] do
  2497. owner:=tdef(owner.defowner).owner;
  2498. if assigned(current_module) and
  2499. (owner.symtabletype=globalsymtable) then
  2500. begin
  2501. if tglobalsymtable(owner).moduleid>=current_module.unitmapsize then
  2502. internalerror(200501152);
  2503. { unit uses count }
  2504. inc(current_module.unitmap[tglobalsymtable(owner).moduleid].refs);
  2505. { Note: don't check the symtable directly as owner might be
  2506. a specialize symtable which is a globalsymtable as well }
  2507. if (
  2508. assigned(current_module.globalsymtable) and
  2509. (current_module.globalsymtable.moduleid<>owner.moduleid)
  2510. ) or (
  2511. assigned(current_module.localsymtable) and
  2512. (current_module.localsymtable.moduleid<>owner.moduleid)
  2513. ) then
  2514. { symbol is imported from another unit }
  2515. current_module.addimportedsym(sym);
  2516. end;
  2517. end;
  2518. function is_owned_by(nesteddef,ownerdef:tdef):boolean;
  2519. begin
  2520. result:=nesteddef=ownerdef;
  2521. if not result and
  2522. { types declared locally in a record method are not defined in the
  2523. record itself }
  2524. not(nesteddef.owner.symtabletype in [localsymtable,parasymtable]) and
  2525. assigned(nesteddef.owner.defowner) then
  2526. result:=is_owned_by(tdef(nesteddef.owner.defowner),ownerdef);
  2527. end;
  2528. function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
  2529. begin
  2530. result:=assigned(childsym) and (childsym.owner=symtable);
  2531. if not result and assigned(childsym) and
  2532. (childsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
  2533. result:=sym_is_owned_by(tabstractrecorddef(childsym.owner.defowner).typesym,symtable);
  2534. end;
  2535. function defs_belong_to_same_generic(def1, def2: tdef): boolean;
  2536. begin
  2537. result:=false;
  2538. if not assigned(def1) or not assigned(def2) then
  2539. exit;
  2540. { for both defs walk to the topmost generic }
  2541. while assigned(def1.owner.defowner) and (df_generic in tstoreddef(def1.owner.defowner).defoptions) do
  2542. def1:=tdef(def1.owner.defowner);
  2543. while assigned(def2.owner.defowner) and (df_generic in tstoreddef(def2.owner.defowner).defoptions) do
  2544. def2:=tdef(def2.owner.defowner);
  2545. result:=def1=def2;
  2546. end;
  2547. function get_generic_in_hierarchy_by_name(srsym: tsym; def: tdef): tdef;
  2548. var
  2549. uname : string;
  2550. begin
  2551. { TODO : check regarding arrays and records declared as their type }
  2552. if not (def.typ in [recorddef,objectdef]) then
  2553. internalerror(2012051501);
  2554. uname:=upper(srsym.realname);
  2555. repeat
  2556. if uname=copy(tabstractrecorddef(def).objname^,1,pos('$',tabstractrecorddef(def).objname^)-1) then
  2557. begin
  2558. result:=def;
  2559. exit;
  2560. end;
  2561. def:=tdef(def.owner.defowner);
  2562. until not assigned(def) or not (def.typ in [recorddef,objectdef]);
  2563. result:=nil;
  2564. end;
  2565. function return_specialization_of_generic(nesteddef,genericdef:tdef; out resultdef:tdef):boolean;
  2566. begin
  2567. { TODO : check regarding arrays and records declared as their type }
  2568. if not (nesteddef.typ in [recorddef,objectdef]) then
  2569. internalerror(2012051601);
  2570. repeat
  2571. if tstoreddef(nesteddef).genericdef=genericdef then
  2572. begin
  2573. resultdef:=nesteddef;
  2574. result:=true;
  2575. exit;
  2576. end;
  2577. nesteddef:=tdef(nesteddef.owner.defowner);
  2578. until not assigned(nesteddef) or not (nesteddef.typ in [recorddef,objectdef]);
  2579. resultdef:=nil;
  2580. result:=false;
  2581. end;
  2582. { symst: symboltable that contains the symbol (-> symowner def: record/objectdef in which the symbol is defined)
  2583. symvisibility: visibility of the symbol
  2584. contextobjdef: via which def the symbol is accessed, e.g.:
  2585. fieldname:=1 -> contextobjdef = current_structdef
  2586. objfield.fieldname:=1 -> contextobjdef = def of objfield
  2587. }
  2588. function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
  2589. var
  2590. symownerdef : tabstractrecorddef;
  2591. nonlocalst : tsymtable;
  2592. isspezproc : boolean;
  2593. begin
  2594. result:=false;
  2595. { Get objdectdef owner of the symtable for the is_related checks }
  2596. if not assigned(symst) or
  2597. not (symst.symtabletype in [objectsymtable,recordsymtable]) then
  2598. internalerror(200810285);
  2599. symownerdef:=tabstractrecorddef(symst.defowner);
  2600. { specializations might belong to a localsymtable or parasymtable }
  2601. nonlocalst:=symownerdef.owner;
  2602. if tstoreddef(symst.defowner).is_specialization then
  2603. while nonlocalst.symtabletype in [localsymtable,parasymtable] do
  2604. nonlocalst:=nonlocalst.defowner.owner;
  2605. isspezproc:=false;
  2606. if assigned(current_procinfo) then
  2607. begin
  2608. if current_procinfo.procdef.is_specialization and
  2609. assigned(current_procinfo.procdef.struct) then
  2610. isspezproc:=true;
  2611. end;
  2612. case symvisibility of
  2613. vis_private :
  2614. begin
  2615. { private symbols are allowed when we are in the same
  2616. module as they are defined }
  2617. result:=(
  2618. (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and
  2619. (nonlocalst.iscurrentunit)
  2620. ) or
  2621. ( // the case of specialize inside the generic declaration and nested types
  2622. (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and
  2623. (
  2624. assigned(current_structdef) and
  2625. (
  2626. (current_structdef=symownerdef) or
  2627. (current_structdef.owner.iscurrentunit)
  2628. )
  2629. ) or
  2630. (
  2631. not assigned(current_structdef) and
  2632. (symownerdef.owner.iscurrentunit)
  2633. ) or
  2634. { access from a generic method that belongs to the class
  2635. but that is specialized elsewere }
  2636. (
  2637. isspezproc and
  2638. (current_procinfo.procdef.struct=current_structdef)
  2639. )
  2640. );
  2641. end;
  2642. vis_strictprivate :
  2643. begin
  2644. result:=assigned(current_structdef) and
  2645. is_owned_by(current_structdef,symownerdef);
  2646. end;
  2647. vis_strictprotected :
  2648. begin
  2649. result:=(
  2650. { access from nested class }
  2651. assigned(current_structdef) and
  2652. is_owned_by(current_structdef,symownerdef)
  2653. ) or
  2654. (
  2655. { access from child class }
  2656. assigned(contextobjdef) and
  2657. assigned(current_structdef) and
  2658. def_is_related(contextobjdef,symownerdef) and
  2659. def_is_related(current_structdef,contextobjdef)
  2660. ) or
  2661. (
  2662. { helpers can access strict protected symbols }
  2663. is_objectpascal_helper(contextobjdef) and
  2664. def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef)
  2665. ) or
  2666. (
  2667. { same as above, but from context of call node inside
  2668. helper method }
  2669. is_objectpascal_helper(current_structdef) and
  2670. def_is_related(tobjectdef(current_structdef).extendeddef,symownerdef)
  2671. );
  2672. end;
  2673. vis_protected :
  2674. begin
  2675. { protected symbols are visible in the module that defines them and
  2676. also visible to related objects. The related object must be defined
  2677. in the current module }
  2678. result:=(
  2679. (
  2680. (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and
  2681. (nonlocalst.iscurrentunit)
  2682. ) or
  2683. (
  2684. assigned(contextobjdef) and
  2685. (contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable,recordsymtable]) and
  2686. (contextobjdef.owner.iscurrentunit) and
  2687. def_is_related(contextobjdef,symownerdef)
  2688. ) or
  2689. ( // the case of specialize inside the generic declaration and nested types
  2690. (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and
  2691. (
  2692. assigned(current_structdef) and
  2693. (
  2694. (current_structdef=symownerdef) or
  2695. (current_structdef.owner.iscurrentunit)
  2696. )
  2697. ) or
  2698. (
  2699. not assigned(current_structdef) and
  2700. (symownerdef.owner.iscurrentunit)
  2701. ) or
  2702. (
  2703. { helpers can access protected symbols }
  2704. is_objectpascal_helper(contextobjdef) and
  2705. def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef)
  2706. )
  2707. ) or
  2708. { access from a generic method that belongs to the class
  2709. but that is specialized elsewere }
  2710. (
  2711. isspezproc and
  2712. (current_procinfo.procdef.struct=current_structdef)
  2713. )
  2714. );
  2715. end;
  2716. vis_public,
  2717. vis_published :
  2718. result:=true;
  2719. end;
  2720. end;
  2721. function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
  2722. begin
  2723. result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef);
  2724. end;
  2725. function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
  2726. var
  2727. i : longint;
  2728. pd : tprocdef;
  2729. begin
  2730. if sym.typ=procsym then
  2731. begin
  2732. { A procsym is visible, when there is at least one of the procdefs visible }
  2733. result:=false;
  2734. for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
  2735. begin
  2736. pd:=tprocdef(tprocsym(sym).ProcdefList[i]);
  2737. if (pd.owner=sym.owner) and
  2738. is_visible_for_object(pd,contextobjdef) then
  2739. begin
  2740. result:=true;
  2741. exit;
  2742. end;
  2743. end;
  2744. end
  2745. else
  2746. result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef);
  2747. end;
  2748. function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2749. begin
  2750. result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[],sp_none);
  2751. end;
  2752. function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  2753. begin
  2754. result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,flags,sp_none);
  2755. end;
  2756. function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
  2757. var
  2758. hashedid: THashedIDString;
  2759. contextstructdef: tabstractrecorddef;
  2760. stackitem: psymtablestackitem;
  2761. begin
  2762. result:=false;
  2763. hashedid.id:=s;
  2764. stackitem:=symtablestack.stack;
  2765. while assigned(stackitem) do
  2766. begin
  2767. srsymtable:=stackitem^.symtable;
  2768. if (srsymtable.symtabletype=objectsymtable) then
  2769. begin
  2770. { TODO : implement the search for an option in classes as well }
  2771. if ssf_search_option in flags then
  2772. begin
  2773. result:=false;
  2774. exit;
  2775. end;
  2776. if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,flags+[ssf_search_helper]) then
  2777. begin
  2778. result:=true;
  2779. exit;
  2780. end;
  2781. end
  2782. else if not((srsymtable.symtabletype=withsymtable) and assigned(srsymtable.defowner) and
  2783. (srsymtable.defowner.typ=undefineddef)) then
  2784. begin
  2785. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2786. { First check if it is a unit/namespace symbol.
  2787. They are visible only if they are from the current unit or
  2788. unit of generic of currently processed specialization. }
  2789. if assigned(srsym) and
  2790. (
  2791. not(srsym.typ in [unitsym,namespacesym]) or
  2792. srsymtable.iscurrentunit or
  2793. (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid))
  2794. ) and
  2795. (not (ssf_search_option in flags) or (option in srsym.symoptions))then
  2796. begin
  2797. { use the class from withsymtable only when it is
  2798. defined in this unit }
  2799. if (srsymtable.symtabletype=withsymtable) and
  2800. assigned(srsymtable.defowner) and
  2801. (srsymtable.defowner.typ in [recorddef,objectdef]) and
  2802. (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
  2803. (srsymtable.defowner.owner.iscurrentunit) then
  2804. contextstructdef:=tabstractrecorddef(srsymtable.defowner)
  2805. else
  2806. contextstructdef:=current_structdef;
  2807. if not(srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
  2808. is_visible_for_object(srsym,contextstructdef) then
  2809. begin
  2810. { we need to know if a procedure references symbols
  2811. in the static symtable, because then it can't be
  2812. inlined from outside this unit }
  2813. if assigned(current_procinfo) and
  2814. (srsym.owner.symtabletype=staticsymtable) then
  2815. include(current_procinfo.flags,pi_uses_static_symtable);
  2816. if not (ssf_no_addsymref in flags) then
  2817. addsymref(srsym);
  2818. result:=true;
  2819. exit;
  2820. end;
  2821. end;
  2822. end;
  2823. stackitem:=stackitem^.next;
  2824. end;
  2825. srsym:=nil;
  2826. srsymtable:=nil;
  2827. end;
  2828. function searchsym_with_symoption(const s: TIDString;out srsym:tsym;out
  2829. srsymtable:TSymtable;option:tsymoption):boolean;
  2830. begin
  2831. result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[ssf_search_option],option);
  2832. end;
  2833. function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2834. var
  2835. hashedid : THashedIDString;
  2836. stackitem : psymtablestackitem;
  2837. classh : tobjectdef;
  2838. begin
  2839. result:=false;
  2840. hashedid.id:=s;
  2841. stackitem:=symtablestack.stack;
  2842. while assigned(stackitem) do
  2843. begin
  2844. {
  2845. It is not possible to have type symbols in:
  2846. parameters
  2847. Exception are classes, objects, records, generic definitions and specializations
  2848. that have the parameterized types inserted in the symtable.
  2849. }
  2850. srsymtable:=stackitem^.symtable;
  2851. if (srsymtable.symtabletype=ObjectSymtable) then
  2852. begin
  2853. classh:=tobjectdef(srsymtable.defowner);
  2854. while assigned(classh) do
  2855. begin
  2856. srsymtable:=classh.symtable;
  2857. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2858. if assigned(srsym) and
  2859. not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
  2860. is_visible_for_object(srsym,current_structdef) then
  2861. begin
  2862. addsymref(srsym);
  2863. result:=true;
  2864. exit;
  2865. end;
  2866. classh:=classh.childof;
  2867. end;
  2868. end
  2869. else
  2870. begin
  2871. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2872. if assigned(srsym) and
  2873. (
  2874. not(srsym.typ in [unitsym,namespacesym]) or
  2875. srsymtable.iscurrentunit or
  2876. (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid))
  2877. ) and
  2878. not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
  2879. (not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,current_structdef)) then
  2880. begin
  2881. { we need to know if a procedure references symbols
  2882. in the static symtable, because then it can't be
  2883. inlined from outside this unit }
  2884. if assigned(current_procinfo) and
  2885. (srsym.owner.symtabletype=staticsymtable) then
  2886. include(current_procinfo.flags,pi_uses_static_symtable);
  2887. addsymref(srsym);
  2888. result:=true;
  2889. exit;
  2890. end;
  2891. end;
  2892. stackitem:=stackitem^.next;
  2893. end;
  2894. result:=false;
  2895. srsym:=nil;
  2896. srsymtable:=nil;
  2897. end;
  2898. function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2899. var
  2900. pmod : tmodule;
  2901. begin
  2902. pmod:=tmodule(pm);
  2903. result:=false;
  2904. if assigned(pmod.globalsymtable) then
  2905. begin
  2906. srsym:=tsym(pmod.globalsymtable.Find(s));
  2907. if assigned(srsym) then
  2908. begin
  2909. srsymtable:=pmod.globalsymtable;
  2910. addsymref(srsym);
  2911. result:=true;
  2912. exit;
  2913. end;
  2914. end;
  2915. { If the module is the current unit we also need
  2916. to search the local symtable }
  2917. if (pmod=current_module) and
  2918. assigned(pmod.localsymtable) then
  2919. begin
  2920. srsym:=tsym(pmod.localsymtable.Find(s));
  2921. if assigned(srsym) then
  2922. begin
  2923. srsymtable:=pmod.localsymtable;
  2924. addsymref(srsym);
  2925. result:=true;
  2926. exit;
  2927. end;
  2928. end;
  2929. srsym:=nil;
  2930. srsymtable:=nil;
  2931. end;
  2932. function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
  2933. var
  2934. stackitem : psymtablestackitem;
  2935. begin
  2936. result:=false;
  2937. stackitem:=symtablestack.stack;
  2938. while assigned(stackitem) do
  2939. begin
  2940. srsymtable:=stackitem^.symtable;
  2941. if (srsymtable.symtabletype=globalsymtable) and
  2942. (srsymtable.name^=unitname) then
  2943. begin
  2944. srsym:=tsym(srsymtable.find(symname));
  2945. if not assigned(srsym) then
  2946. break;
  2947. result:=true;
  2948. exit;
  2949. end;
  2950. stackitem:=stackitem^.next;
  2951. end;
  2952. { If the module is the current unit we also need
  2953. to search the local symtable }
  2954. if assigned(current_module.localsymtable) and
  2955. (current_module.localsymtable.name^=unitname) then
  2956. begin
  2957. srsymtable:=current_module.localsymtable;
  2958. srsym:=tsym(srsymtable.find(symname));
  2959. if assigned(srsym) then
  2960. begin
  2961. result:=true;
  2962. exit;
  2963. end;
  2964. end;
  2965. end;
  2966. function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef;
  2967. begin
  2968. result:=pd;
  2969. if pd.typ<>objectdef then
  2970. exit;
  2971. result:=find_real_class_definition(tobjectdef(pd),erroronfailure);
  2972. end;
  2973. function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
  2974. var
  2975. hashedid : THashedIDString;
  2976. stackitem : psymtablestackitem;
  2977. srsymtable : tsymtable;
  2978. srsym : tsym;
  2979. formalname,
  2980. foundname : shortstring;
  2981. formalnameptr,
  2982. foundnameptr: pshortstring;
  2983. begin
  2984. { not a formal definition -> return it }
  2985. if not(oo_is_formal in pd.objectoptions) then
  2986. begin
  2987. result:=pd;
  2988. exit;
  2989. end;
  2990. hashedid.id:=pd.typesym.name;
  2991. stackitem:=symtablestack.stack;
  2992. while assigned(stackitem) do
  2993. begin
  2994. srsymtable:=stackitem^.symtable;
  2995. { ObjC classes can't appear in generics or as nested class
  2996. definitions. Java classes can. }
  2997. if not(srsymtable.symtabletype in [recordsymtable,parasymtable]) or
  2998. (is_java_class_or_interface(pd) and
  2999. (srsymtable.symtabletype=ObjectSymtable)) then
  3000. begin
  3001. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3002. if assigned(srsym) and
  3003. (srsym.typ=typesym) and
  3004. (ttypesym(srsym).typedef.typ=objectdef) and
  3005. (tobjectdef(ttypesym(srsym).typedef).objecttype=pd.objecttype) and
  3006. not(oo_is_formal in tobjectdef(ttypesym(srsym).typedef).objectoptions) then
  3007. begin
  3008. if not(oo_is_forward in tobjectdef(ttypesym(srsym).typedef).objectoptions) then
  3009. begin
  3010. { the external name for the formal and the real
  3011. definition must match }
  3012. if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) or
  3013. assigned(pd.import_lib) then
  3014. begin
  3015. if assigned(pd.import_lib) then
  3016. formalname:=pd.import_lib^+'.'
  3017. else
  3018. formalname:='';
  3019. formalname:=formalname+pd.objextname^;
  3020. if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) then
  3021. foundname:=tobjectdef(ttypesym(srsym).typedef).import_lib^+'.'
  3022. else
  3023. foundname:='';
  3024. foundname:=foundname+tobjectdef(ttypesym(srsym).typedef).objextname^;
  3025. formalnameptr:=@formalname;
  3026. foundnameptr:=@foundname;
  3027. end
  3028. else
  3029. begin
  3030. formalnameptr:=pd.objextname;
  3031. foundnameptr:=tobjectdef(ttypesym(srsym).typedef).objextname;
  3032. end;
  3033. if foundnameptr^<>formalnameptr^ then
  3034. begin
  3035. MessagePos2(pd.typesym.fileinfo,sym_e_external_class_name_mismatch1,formalnameptr^,pd.typename);
  3036. MessagePos1(srsym.fileinfo,sym_e_external_class_name_mismatch2,foundnameptr^);
  3037. end;
  3038. end;
  3039. result:=tobjectdef(ttypesym(srsym).typedef);
  3040. if assigned(current_procinfo) and
  3041. (srsym.owner.symtabletype=staticsymtable) then
  3042. include(current_procinfo.flags,pi_uses_static_symtable);
  3043. addsymref(srsym);
  3044. exit;
  3045. end;
  3046. end;
  3047. stackitem:=stackitem^.next;
  3048. end;
  3049. { nothing found: optionally give an error and return the original
  3050. (empty) one }
  3051. if erroronfailure then
  3052. Message1(sym_e_formal_class_not_resolved,pd.objrealname^);
  3053. result:=pd;
  3054. end;
  3055. function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  3056. var
  3057. hashedid : THashedIDString;
  3058. orgclass : tobjectdef;
  3059. i : longint;
  3060. begin
  3061. orgclass:=classh;
  3062. { in case this is a formal class, first find the real definition }
  3063. if assigned(classh) then
  3064. begin
  3065. if (oo_is_formal in classh.objectoptions) then
  3066. classh:=find_real_class_definition(classh,true);
  3067. { The contextclassh is used for visibility. The classh must be equal to
  3068. or be a parent of contextclassh. E.g. for inherited searches the classh is the
  3069. parent or a class helper. }
  3070. if not (def_is_related(contextclassh,classh) or
  3071. (is_classhelper(contextclassh) and
  3072. assigned(tobjectdef(contextclassh).extendeddef) and
  3073. (tobjectdef(contextclassh).extendeddef.typ=objectdef) and
  3074. def_is_related(tobjectdef(contextclassh).extendeddef,classh))) then
  3075. internalerror(200811161);
  3076. end;
  3077. result:=false;
  3078. hashedid.id:=s;
  3079. { an Objective-C protocol or Java interface can inherit from multiple
  3080. other protocols/interfaces -> use ImplementedInterfaces instead }
  3081. if is_objcprotocol(classh) or
  3082. is_javainterface(classh) then
  3083. begin
  3084. srsymtable:=classh.symtable;
  3085. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3086. if assigned(srsym) and
  3087. is_visible_for_object(srsym,contextclassh) then
  3088. begin
  3089. if not (ssf_no_addsymref in flags) then
  3090. addsymref(srsym);
  3091. result:=true;
  3092. exit;
  3093. end;
  3094. for i:=0 to classh.ImplementedInterfaces.count-1 do
  3095. begin
  3096. if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,flags-[ssf_search_helper]) then
  3097. begin
  3098. result:=true;
  3099. exit;
  3100. end;
  3101. end;
  3102. end
  3103. else
  3104. if is_objectpascal_helper(classh) then
  3105. begin
  3106. { helpers have their own obscure search logic... }
  3107. result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,flags-[ssf_has_inherited]);
  3108. if result then
  3109. exit;
  3110. end
  3111. else
  3112. begin
  3113. while assigned(classh) do
  3114. begin
  3115. { search for a class helper method first if this is an Object
  3116. Pascal class and we haven't yet found a helper symbol }
  3117. if is_class(classh) and
  3118. (ssf_search_helper in flags) then
  3119. begin
  3120. result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable);
  3121. { an eventual overload inside the extended type's hierarchy
  3122. will be found by tcallcandidates }
  3123. if result then
  3124. exit;
  3125. end;
  3126. srsymtable:=classh.symtable;
  3127. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3128. if assigned(srsym) and
  3129. is_visible_for_object(srsym,contextclassh) then
  3130. begin
  3131. if not (ssf_no_addsymref in flags) then
  3132. addsymref(srsym);
  3133. result:=true;
  3134. exit;
  3135. end;
  3136. classh:=classh.childof;
  3137. end;
  3138. end;
  3139. if is_objcclass(orgclass) then
  3140. result:=search_objc_helper(orgclass,s,srsym,srsymtable)
  3141. else
  3142. begin
  3143. srsym:=nil;
  3144. srsymtable:=nil;
  3145. end;
  3146. end;
  3147. function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  3148. var
  3149. hashedid : THashedIDString;
  3150. begin
  3151. result:=false;
  3152. hashedid.id:=s;
  3153. { search for a record helper method first }
  3154. result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable);
  3155. if result then
  3156. { an eventual overload inside the extended type's hierarchy
  3157. will be found by tcallcandidates }
  3158. exit;
  3159. srsymtable:=recordh.symtable;
  3160. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3161. if assigned(srsym) and is_visible_for_object(srsym,recordh) then
  3162. begin
  3163. addsymref(srsym);
  3164. result:=true;
  3165. exit;
  3166. end;
  3167. srsym:=nil;
  3168. srsymtable:=nil;
  3169. end;
  3170. function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
  3171. var
  3172. def : tdef;
  3173. i : longint;
  3174. begin
  3175. { in case this is a formal class, first find the real definition }
  3176. if assigned(classh) and
  3177. (oo_is_formal in classh.objectoptions) then
  3178. classh:=find_real_class_definition(classh,true);
  3179. result:=false;
  3180. def:=nil;
  3181. while assigned(classh) do
  3182. begin
  3183. for i:=0 to classh.symtable.DefList.Count-1 do
  3184. begin
  3185. def:=tstoreddef(classh.symtable.DefList[i]);
  3186. { Find also all hidden private methods to
  3187. be compatible with delphi, see tw6203 (PFV) }
  3188. if (def.typ=procdef) and
  3189. (po_msgint in tprocdef(def).procoptions) and
  3190. (tprocdef(def).messageinf.i=msgid) then
  3191. begin
  3192. srdef:=def;
  3193. srsym:=tprocdef(def).procsym;
  3194. srsymtable:=classh.symtable;
  3195. addsymref(srsym);
  3196. result:=true;
  3197. exit;
  3198. end;
  3199. end;
  3200. classh:=classh.childof;
  3201. end;
  3202. srdef:=nil;
  3203. srsym:=nil;
  3204. srsymtable:=nil;
  3205. end;
  3206. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
  3207. var
  3208. def : tdef;
  3209. i : longint;
  3210. begin
  3211. { in case this is a formal class, first find the real definition }
  3212. if assigned(classh) and
  3213. (oo_is_formal in classh.objectoptions) then
  3214. classh:=find_real_class_definition(classh,true);
  3215. result:=false;
  3216. def:=nil;
  3217. while assigned(classh) do
  3218. begin
  3219. for i:=0 to classh.symtable.DefList.Count-1 do
  3220. begin
  3221. def:=tstoreddef(classh.symtable.DefList[i]);
  3222. { Find also all hidden private methods to
  3223. be compatible with delphi, see tw6203 (PFV) }
  3224. if (def.typ=procdef) and
  3225. (po_msgstr in tprocdef(def).procoptions) and
  3226. (tprocdef(def).messageinf.str^=s) then
  3227. begin
  3228. srsym:=tprocdef(def).procsym;
  3229. srsymtable:=classh.symtable;
  3230. addsymref(srsym);
  3231. result:=true;
  3232. exit;
  3233. end;
  3234. end;
  3235. classh:=classh.childof;
  3236. end;
  3237. srsym:=nil;
  3238. srsymtable:=nil;
  3239. end;
  3240. function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
  3241. var
  3242. hashedid : THashedIDString;
  3243. parentclassh : tobjectdef;
  3244. begin
  3245. result:=false;
  3246. if not is_objectpascal_helper(classh) then
  3247. Internalerror(2011030101);
  3248. hashedid.id:=s;
  3249. { in a helper things are a bit more complex:
  3250. 1. search the symbol in the helper (if not "inherited")
  3251. 2. search the symbol in the extended type
  3252. 3. search the symbol in the parent helpers
  3253. 4. only classes: search the symbol in the parents of the extended type
  3254. }
  3255. if not (ssf_has_inherited in flags) then
  3256. begin
  3257. { search in the helper itself }
  3258. srsymtable:=classh.symtable;
  3259. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3260. if assigned(srsym) and
  3261. is_visible_for_object(srsym,contextclassh) then
  3262. begin
  3263. if not (ssf_no_addsymref in flags) then
  3264. addsymref(srsym);
  3265. result:=true;
  3266. exit;
  3267. end;
  3268. end;
  3269. { now search in the extended type itself }
  3270. { Note: the extendeddef might be Nil if we are currently parsing the
  3271. extended type itself and the identifier was not found }
  3272. if assigned(classh.extendeddef) and (classh.extendeddef.typ in [recorddef,objectdef]) then
  3273. begin
  3274. srsymtable:=tabstractrecorddef(classh.extendeddef).symtable;
  3275. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3276. if assigned(srsym) and
  3277. is_visible_for_object(srsym,contextclassh) then
  3278. begin
  3279. if not (ssf_no_addsymref in flags) then
  3280. addsymref(srsym);
  3281. result:=true;
  3282. exit;
  3283. end;
  3284. end;
  3285. { now search in the parent helpers }
  3286. parentclassh:=classh.childof;
  3287. while assigned(parentclassh) do
  3288. begin
  3289. srsymtable:=parentclassh.symtable;
  3290. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3291. if assigned(srsym) and
  3292. is_visible_for_object(srsym,contextclassh) then
  3293. begin
  3294. if not (ssf_no_addsymref in flags) then
  3295. addsymref(srsym);
  3296. result:=true;
  3297. exit;
  3298. end;
  3299. parentclassh:=parentclassh.childof;
  3300. end;
  3301. if is_class(classh.extendeddef) then
  3302. { now search in the parents of the extended class (with helpers!) }
  3303. result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,flags+[ssf_search_helper]);
  3304. { addsymref is already called by searchsym_in_class }
  3305. end;
  3306. function search_specific_assignment_operator(assignment_type:ttoken;from_def,to_def:Tdef):Tprocdef;
  3307. var
  3308. sym : Tprocsym;
  3309. hashedid : THashedIDString;
  3310. curreq,
  3311. besteq : tequaltype;
  3312. currpd,
  3313. bestpd : tprocdef;
  3314. stackitem : psymtablestackitem;
  3315. begin
  3316. hashedid.id:=overloaded_names[assignment_type];
  3317. besteq:=te_incompatible;
  3318. bestpd:=nil;
  3319. stackitem:=symtablestack.stack;
  3320. while assigned(stackitem) do
  3321. begin
  3322. sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
  3323. if sym<>nil then
  3324. begin
  3325. if sym.typ<>procsym then
  3326. internalerror(200402031);
  3327. { if the source type is an alias then this is only the second choice,
  3328. if you mess with this code, check tw4093 }
  3329. currpd:=sym.find_procdef_assignment_operator(from_def,to_def,curreq);
  3330. if curreq>besteq then
  3331. begin
  3332. besteq:=curreq;
  3333. bestpd:=currpd;
  3334. if (besteq=te_exact) then
  3335. break;
  3336. end;
  3337. end;
  3338. stackitem:=stackitem^.next;
  3339. end;
  3340. result:=bestpd;
  3341. end;
  3342. function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
  3343. begin
  3344. { search record/object symtable first for a suitable operator }
  3345. if from_def.typ in [recorddef,objectdef] then
  3346. symtablestack.push(tabstractrecorddef(from_def).symtable);
  3347. if to_def.typ in [recorddef,objectdef] then
  3348. symtablestack.push(tabstractrecorddef(to_def).symtable);
  3349. { if type conversion is explicit then search first for explicit
  3350. operator overload and if not found then use implicit operator }
  3351. if explicit then
  3352. result:=search_specific_assignment_operator(_OP_EXPLICIT,from_def,to_def)
  3353. else
  3354. result:=nil;
  3355. if result=nil then
  3356. result:=search_specific_assignment_operator(_ASSIGNMENT,from_def,to_def);
  3357. { restore symtable stack }
  3358. if to_def.typ in [recorddef,objectdef] then
  3359. symtablestack.pop(tabstractrecorddef(to_def).symtable);
  3360. if from_def.typ in [recorddef,objectdef] then
  3361. symtablestack.pop(tabstractrecorddef(from_def).symtable);
  3362. end;
  3363. function search_enumerator_operator(from_def,to_def:Tdef): Tprocdef;
  3364. var
  3365. sym : Tprocsym;
  3366. hashedid : THashedIDString;
  3367. curreq,
  3368. besteq : tequaltype;
  3369. currpd,
  3370. bestpd : tprocdef;
  3371. stackitem : psymtablestackitem;
  3372. begin
  3373. hashedid.id:='enumerator';
  3374. besteq:=te_incompatible;
  3375. bestpd:=nil;
  3376. stackitem:=symtablestack.stack;
  3377. while assigned(stackitem) do
  3378. begin
  3379. sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
  3380. if sym<>nil then
  3381. begin
  3382. if sym.typ<>procsym then
  3383. internalerror(200910241);
  3384. { if the source type is an alias then this is only the second choice,
  3385. if you mess with this code, check tw4093 }
  3386. currpd:=sym.find_procdef_enumerator_operator(from_def,to_def,curreq);
  3387. if curreq>besteq then
  3388. begin
  3389. besteq:=curreq;
  3390. bestpd:=currpd;
  3391. if (besteq=te_exact) then
  3392. break;
  3393. end;
  3394. end;
  3395. stackitem:=stackitem^.next;
  3396. end;
  3397. result:=bestpd;
  3398. end;
  3399. function search_system_type(const s: TIDString): ttypesym;
  3400. var
  3401. sym : tsym;
  3402. begin
  3403. sym:=tsym(systemunit.Find(s));
  3404. if not assigned(sym) or
  3405. (sym.typ<>typesym) then
  3406. message1(cg_f_unknown_system_type,s);
  3407. result:=ttypesym(sym);
  3408. end;
  3409. function try_search_system_type(const s: TIDString): ttypesym;
  3410. var
  3411. sym : tsym;
  3412. begin
  3413. sym:=tsym(systemunit.Find(s));
  3414. if not assigned(sym) then
  3415. result:=nil
  3416. else
  3417. begin
  3418. if sym.typ<>typesym then
  3419. message1(cg_f_unknown_system_type,s);
  3420. result:=ttypesym(sym);
  3421. end;
  3422. end;
  3423. function try_search_current_module_type(const s: TIDString): ttypesym;
  3424. var
  3425. found: boolean;
  3426. srsymtable: tsymtable;
  3427. srsym: tsym;
  3428. begin
  3429. if s[1]='$' then
  3430. found:=searchsym_in_module(current_module,copy(s,2,length(s)),srsym,srsymtable)
  3431. else
  3432. found:=searchsym_in_module(current_module,s,srsym,srsymtable);
  3433. if found then
  3434. begin
  3435. if (srsym.typ<>typesym) then
  3436. internalerror(2014091207);
  3437. result:=ttypesym(srsym);
  3438. end
  3439. else
  3440. result:=nil;
  3441. end;
  3442. function search_system_proc(const s: TIDString): tprocdef;
  3443. var
  3444. srsym: tsym;
  3445. begin
  3446. srsym:=tsym(systemunit.find(s));
  3447. if not assigned(srsym) and
  3448. (cs_compilesystem in current_settings.moduleswitches) then
  3449. srsym:=tsym(systemunit.Find(upper(s)));
  3450. if not assigned(srsym) or
  3451. (srsym.typ<>procsym) then
  3452. message1(cg_f_unknown_compilerproc,s);
  3453. result:=tprocdef(tprocsym(srsym).procdeflist[0]);
  3454. end;
  3455. function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
  3456. var
  3457. srsymtable: tsymtable;
  3458. sym: tsym;
  3459. begin
  3460. sym:=nil;
  3461. if searchsym_in_named_module(unitname,typename,sym,srsymtable) and
  3462. (sym.typ=typesym) then
  3463. begin
  3464. result:=ttypesym(sym);
  3465. exit;
  3466. end
  3467. else
  3468. begin
  3469. if throwerror then
  3470. message2(cg_f_unknown_type_in_unit,typename,unitname);
  3471. result:=nil;
  3472. end;
  3473. end;
  3474. function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
  3475. var
  3476. s: string;
  3477. list: TFPObjectList;
  3478. i: integer;
  3479. st: tsymtable;
  3480. begin
  3481. result:=false;
  3482. odef:=nil;
  3483. { when there are no helpers active currently then we don't need to do
  3484. anything }
  3485. if current_module.extendeddefs.count=0 then
  3486. exit;
  3487. { no helpers for anonymous types }
  3488. if ((pd.typ in [recorddef,objectdef]) and
  3489. (
  3490. not assigned(tabstractrecorddef(pd).objrealname) or
  3491. (tabstractrecorddef(pd).objrealname^='')
  3492. )
  3493. ) or
  3494. not assigned(pd.typesym) then
  3495. exit;
  3496. { if pd is defined inside a procedure we must not use make_mangledname
  3497. (as a helper may not be defined in a procedure this is no problem...)}
  3498. st:=pd.owner;
  3499. while st.symtabletype in [objectsymtable,recordsymtable] do
  3500. st:=st.defowner.owner;
  3501. if st.symtabletype=localsymtable then
  3502. exit;
  3503. { the mangled name is used as the key for tmodule.extendeddefs }
  3504. s:=generate_objectpascal_helper_key(pd);
  3505. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  3506. if assigned(list) and (list.count>0) then
  3507. begin
  3508. i:=list.count-1;
  3509. repeat
  3510. odef:=tobjectdef(list[list.count-1]);
  3511. result:=(odef.owner.symtabletype in [staticsymtable,globalsymtable]) or
  3512. is_visible_for_object(tobjectdef(list[i]).typesym,contextclassh);
  3513. dec(i);
  3514. until result or (i<0);
  3515. if not result then
  3516. { just to be sure that noone uses odef }
  3517. odef:=nil;
  3518. end;
  3519. end;
  3520. function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  3521. var
  3522. hashedid : THashedIDString;
  3523. classh : tobjectdef;
  3524. i : integer;
  3525. pdef : tprocdef;
  3526. begin
  3527. result:=false;
  3528. { if there is no class helper for the class then there is no need to
  3529. search further }
  3530. if not search_last_objectpascal_helper(pd,contextclassh,classh) then
  3531. exit;
  3532. hashedid.id:=s;
  3533. repeat
  3534. srsymtable:=classh.symtable;
  3535. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3536. if srsym<>nil then
  3537. begin
  3538. case srsym.typ of
  3539. procsym:
  3540. begin
  3541. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  3542. begin
  3543. pdef:=tprocdef(tprocsym(srsym).procdeflist[i]);
  3544. if not is_visible_for_object(pdef.owner,pdef.visibility,contextclassh) then
  3545. continue;
  3546. { we need to know if a procedure references symbols
  3547. in the static symtable, because then it can't be
  3548. inlined from outside this unit }
  3549. if assigned(current_procinfo) and
  3550. (srsym.owner.symtabletype=staticsymtable) then
  3551. include(current_procinfo.flags,pi_uses_static_symtable);
  3552. { the first found method wins }
  3553. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  3554. srsymtable:=srsym.owner;
  3555. addsymref(srsym);
  3556. result:=true;
  3557. exit;
  3558. end;
  3559. end;
  3560. typesym,
  3561. fieldvarsym,
  3562. constsym,
  3563. enumsym,
  3564. undefinedsym,
  3565. propertysym:
  3566. begin
  3567. addsymref(srsym);
  3568. result:=true;
  3569. exit;
  3570. end;
  3571. else
  3572. internalerror(2014041101);
  3573. end;
  3574. end;
  3575. { try the helper parent if available }
  3576. classh:=classh.childof;
  3577. until classh=nil;
  3578. srsym:=nil;
  3579. srsymtable:=nil;
  3580. end;
  3581. function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  3582. var
  3583. hashedid : THashedIDString;
  3584. stackitem : psymtablestackitem;
  3585. i : longint;
  3586. defowner : tobjectdef;
  3587. begin
  3588. hashedid.id:=class_helper_prefix+s;
  3589. stackitem:=symtablestack.stack;
  3590. while assigned(stackitem) do
  3591. begin
  3592. srsymtable:=stackitem^.symtable;
  3593. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3594. if assigned(srsym) then
  3595. begin
  3596. if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
  3597. not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
  3598. (srsym.typ<>procsym) then
  3599. internalerror(2009111505);
  3600. { check whether this procsym includes a helper for this particular class }
  3601. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  3602. begin
  3603. { does pd inherit from (or is the same as) the class
  3604. that this method's category extended?
  3605. Warning: this list contains both category and objcclass methods
  3606. (for id.randommethod), so only check category methods here
  3607. }
  3608. defowner:=tobjectdef(tprocdef(tprocsym(srsym).procdeflist[i]).owner.defowner);
  3609. if is_objccategory(defowner) and
  3610. def_is_related(pd,defowner.childof) then
  3611. begin
  3612. { we need to know if a procedure references symbols
  3613. in the static symtable, because then it can't be
  3614. inlined from outside this unit }
  3615. if assigned(current_procinfo) and
  3616. (srsym.owner.symtabletype=staticsymtable) then
  3617. include(current_procinfo.flags,pi_uses_static_symtable);
  3618. { no need to keep looking. There might be other
  3619. categories that extend this, a parent or child
  3620. class with a method with the same name (either
  3621. overriding this one, or overridden by this one),
  3622. but that doesn't matter as far as the basic
  3623. procsym is concerned.
  3624. }
  3625. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  3626. srsymtable:=srsym.owner;
  3627. addsymref(srsym);
  3628. result:=true;
  3629. exit;
  3630. end;
  3631. end;
  3632. end;
  3633. stackitem:=stackitem^.next;
  3634. end;
  3635. srsym:=nil;
  3636. srsymtable:=nil;
  3637. result:=false;
  3638. end;
  3639. function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  3640. var
  3641. hashedid : THashedIDString;
  3642. stackitem : psymtablestackitem;
  3643. i : longint;
  3644. begin
  3645. hashedid.id:=class_helper_prefix+s;
  3646. stackitem:=symtablestack.stack;
  3647. while assigned(stackitem) do
  3648. begin
  3649. srsymtable:=stackitem^.symtable;
  3650. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  3651. if assigned(srsym) then
  3652. begin
  3653. if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
  3654. not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
  3655. (srsym.typ<>procsym) then
  3656. internalerror(2009112005);
  3657. { check whether this procsym includes a helper for this particular class }
  3658. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  3659. begin
  3660. { we need to know if a procedure references symbols
  3661. in the static symtable, because then it can't be
  3662. inlined from outside this unit }
  3663. if assigned(current_procinfo) and
  3664. (srsym.owner.symtabletype=staticsymtable) then
  3665. include(current_procinfo.flags,pi_uses_static_symtable);
  3666. { no need to keep looking. There might be other
  3667. methods with the same name, but that doesn't matter
  3668. as far as the basic procsym is concerned.
  3669. }
  3670. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  3671. { We need the symtable in which the classhelper-like sym
  3672. is located, not the objectdef. The reason is that the
  3673. callnode will climb the symtablestack until it encounters
  3674. this symtable to start looking for overloads (and it won't
  3675. find the objectsymtable in which this method sym is
  3676. located
  3677. srsymtable:=srsym.owner;
  3678. }
  3679. addsymref(srsym);
  3680. result:=true;
  3681. exit;
  3682. end;
  3683. end;
  3684. stackitem:=stackitem^.next;
  3685. end;
  3686. srsym:=nil;
  3687. srsymtable:=nil;
  3688. result:=false;
  3689. end;
  3690. function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
  3691. { searches n in symtable of pd and all anchestors }
  3692. var
  3693. srsymtable : tsymtable;
  3694. begin
  3695. { in case this is a formal class, first find the real definition }
  3696. if (oo_is_formal in pd.objectoptions) then
  3697. pd:=find_real_class_definition(tobjectdef(pd),true);
  3698. if search_objectpascal_helper(pd, pd, s, result, srsymtable) then
  3699. exit;
  3700. result:=search_struct_member_no_helper(pd,s);
  3701. if assigned(result) then
  3702. exit;
  3703. { not found, now look for class helpers }
  3704. if is_objcclass(pd) then
  3705. search_objc_helper(tobjectdef(pd),s,result,srsymtable)
  3706. end;
  3707. function search_struct_member_no_helper(pd: tabstractrecorddef; const s: string): tsym;
  3708. var
  3709. hashedid : THashedIDString;
  3710. srsym : tsym;
  3711. begin
  3712. hashedid.id:=s;
  3713. while assigned(pd) do
  3714. begin
  3715. srsym:=tsym(pd.symtable.FindWithHash(hashedid));
  3716. if assigned(srsym) then
  3717. begin
  3718. result:=srsym;
  3719. exit;
  3720. end;
  3721. if pd.typ=objectdef then
  3722. pd:=tobjectdef(pd).childof
  3723. else
  3724. pd:=nil;
  3725. end;
  3726. result:=nil;
  3727. end;
  3728. function search_macro(const s : string):tsym;
  3729. var
  3730. stackitem : psymtablestackitem;
  3731. hashedid : THashedIDString;
  3732. srsym : tsym;
  3733. begin
  3734. hashedid.id:=s;
  3735. { First search the localmacrosymtable before searching the
  3736. global macrosymtables from the units }
  3737. if assigned(current_module) then
  3738. begin
  3739. srsym:=tsym(current_module.localmacrosymtable.FindWithHash(hashedid));
  3740. if assigned(srsym) then
  3741. begin
  3742. result:= srsym;
  3743. exit;
  3744. end;
  3745. end;
  3746. stackitem:=macrosymtablestack.stack;
  3747. while assigned(stackitem) do
  3748. begin
  3749. srsym:=tsym(stackitem^.symtable.FindWithHash(hashedid));
  3750. if assigned(srsym) then
  3751. begin
  3752. result:= srsym;
  3753. exit;
  3754. end;
  3755. stackitem:=stackitem^.next;
  3756. end;
  3757. result:= nil;
  3758. end;
  3759. function defined_macro(const s : string):boolean;
  3760. var
  3761. mac: tmacro;
  3762. begin
  3763. mac:=tmacro(search_macro(s));
  3764. if assigned(mac) then
  3765. begin
  3766. mac.is_used:=true;
  3767. defined_macro:=mac.defined;
  3768. end
  3769. else
  3770. defined_macro:=false;
  3771. end;
  3772. {****************************************************************************
  3773. Object Helpers
  3774. ****************************************************************************}
  3775. function search_default_property(pd : tabstractrecorddef) : tpropertysym;
  3776. { returns the default property of a class, searches also anchestors }
  3777. var
  3778. _defaultprop : tpropertysym;
  3779. helperpd : tobjectdef;
  3780. begin
  3781. _defaultprop:=nil;
  3782. { first search in helper's hierarchy }
  3783. if search_last_objectpascal_helper(pd,nil,helperpd) then
  3784. while assigned(helperpd) do
  3785. begin
  3786. helperpd.symtable.SymList.ForEachCall(@tstoredsymtable(helperpd.symtable).testfordefaultproperty,@_defaultprop);
  3787. if assigned(_defaultprop) then
  3788. break;
  3789. helperpd:=helperpd.childof;
  3790. end;
  3791. if assigned(_defaultprop) then
  3792. begin
  3793. search_default_property:=_defaultprop;
  3794. exit;
  3795. end;
  3796. { now search in the type's hierarchy itself }
  3797. while assigned(pd) do
  3798. begin
  3799. pd.symtable.SymList.ForEachCall(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop);
  3800. if assigned(_defaultprop) then
  3801. break;
  3802. if (pd.typ=objectdef) then
  3803. pd:=tobjectdef(pd).childof
  3804. else
  3805. break;
  3806. end;
  3807. search_default_property:=_defaultprop;
  3808. end;
  3809. {****************************************************************************
  3810. Macro Helpers
  3811. ****************************************************************************}
  3812. procedure def_system_macro(const name : string);
  3813. var
  3814. mac : tmacro;
  3815. s: string;
  3816. begin
  3817. if name = '' then
  3818. internalerror(2004121202);
  3819. s:= upper(name);
  3820. mac:=tmacro(search_macro(s));
  3821. if not assigned(mac) then
  3822. begin
  3823. mac:=tmacro.create(s);
  3824. if assigned(current_module) then
  3825. current_module.localmacrosymtable.insert(mac)
  3826. else
  3827. initialmacrosymtable.insert(mac);
  3828. end;
  3829. Message1(parser_c_macro_defined,mac.name);
  3830. mac.defined:=true;
  3831. end;
  3832. procedure set_system_macro(const name, value : string);
  3833. var
  3834. mac : tmacro;
  3835. s: string;
  3836. begin
  3837. if name = '' then
  3838. internalerror(2004121203);
  3839. s:= upper(name);
  3840. mac:=tmacro(search_macro(s));
  3841. if not assigned(mac) then
  3842. begin
  3843. mac:=tmacro.create(s);
  3844. if assigned(current_module) then
  3845. current_module.localmacrosymtable.insert(mac)
  3846. else
  3847. initialmacrosymtable.insert(mac);
  3848. end
  3849. else
  3850. begin
  3851. mac.is_compiler_var:=false;
  3852. if assigned(mac.buftext) then
  3853. freemem(mac.buftext,mac.buflen);
  3854. end;
  3855. Message2(parser_c_macro_set_to,mac.name,value);
  3856. mac.buflen:=length(value);
  3857. getmem(mac.buftext,mac.buflen);
  3858. move(value[1],mac.buftext^,mac.buflen);
  3859. mac.defined:=true;
  3860. end;
  3861. procedure set_system_compvar(const name, value : string);
  3862. var
  3863. mac : tmacro;
  3864. s: string;
  3865. begin
  3866. if name = '' then
  3867. internalerror(2004121204);
  3868. s:= upper(name);
  3869. mac:=tmacro(search_macro(s));
  3870. if not assigned(mac) then
  3871. begin
  3872. mac:=tmacro.create(s);
  3873. mac.is_compiler_var:=true;
  3874. if assigned(current_module) then
  3875. current_module.localmacrosymtable.insert(mac)
  3876. else
  3877. initialmacrosymtable.insert(mac);
  3878. end
  3879. else
  3880. begin
  3881. mac.is_compiler_var:=true;
  3882. if assigned(mac.buftext) then
  3883. freemem(mac.buftext,mac.buflen);
  3884. end;
  3885. Message2(parser_c_macro_set_to,mac.name,value);
  3886. mac.buflen:=length(value);
  3887. getmem(mac.buftext,mac.buflen);
  3888. move(value[1],mac.buftext^,mac.buflen);
  3889. mac.defined:=true;
  3890. end;
  3891. procedure undef_system_macro(const name : string);
  3892. var
  3893. mac : tmacro;
  3894. s: string;
  3895. begin
  3896. if name = '' then
  3897. internalerror(2004121205);
  3898. s:= upper(name);
  3899. mac:=tmacro(search_macro(s));
  3900. if not assigned(mac) then
  3901. {If not found, then it's already undefined.}
  3902. else
  3903. begin
  3904. Message1(parser_c_macro_undefined,mac.name);
  3905. mac.defined:=false;
  3906. mac.is_compiler_var:=false;
  3907. { delete old definition }
  3908. if assigned(mac.buftext) then
  3909. begin
  3910. freemem(mac.buftext,mac.buflen);
  3911. mac.buftext:=nil;
  3912. end;
  3913. end;
  3914. end;
  3915. {$ifdef UNITALIASES}
  3916. {****************************************************************************
  3917. TUNIT_ALIAS
  3918. ****************************************************************************}
  3919. constructor tunit_alias.create(const n:string);
  3920. var
  3921. i : longint;
  3922. begin
  3923. i:=pos('=',n);
  3924. if i=0 then
  3925. fail;
  3926. inherited createname(Copy(n,1,i-1));
  3927. newname:=stringdup(Copy(n,i+1,255));
  3928. end;
  3929. destructor tunit_alias.destroy;
  3930. begin
  3931. stringdispose(newname);
  3932. inherited destroy;
  3933. end;
  3934. procedure addunitalias(const n:string);
  3935. begin
  3936. unitaliases^.insert(tunit_alias,init(Upper(n))));
  3937. end;
  3938. function getunitalias(const n:string):string;
  3939. var
  3940. p : punit_alias;
  3941. begin
  3942. p:=punit_alias(unitaliases^.Find(Upper(n)));
  3943. if assigned(p) then
  3944. getunitalias:=punit_alias(p).newname^
  3945. else
  3946. getunitalias:=n;
  3947. end;
  3948. {$endif UNITALIASES}
  3949. {****************************************************************************
  3950. Init/Done Symtable
  3951. ****************************************************************************}
  3952. procedure InitSymtable;
  3953. begin
  3954. { Reset symbolstack }
  3955. symtablestack:=nil;
  3956. systemunit:=nil;
  3957. { create error syms and def }
  3958. generrorsym:=terrorsym.create;
  3959. generrordef:=cerrordef.create;
  3960. { macros }
  3961. initialmacrosymtable:=tmacrosymtable.create(false);
  3962. macrosymtablestack:=TSymtablestack.create;
  3963. macrosymtablestack.push(initialmacrosymtable);
  3964. {$ifdef UNITALIASES}
  3965. { unit aliases }
  3966. unitaliases:=TFPHashObjectList.create;
  3967. {$endif}
  3968. { set some global vars to nil, might be important for the ide }
  3969. class_tobject:=nil;
  3970. interface_iunknown:=nil;
  3971. interface_idispatch:=nil;
  3972. rec_tguid:=nil;
  3973. rec_jmp_buf:=nil;
  3974. rec_exceptaddr:=nil;
  3975. objc_metaclasstype:=nil;
  3976. objc_superclasstype:=nil;
  3977. objc_idtype:=nil;
  3978. objc_seltype:=nil;
  3979. objc_objecttype:=nil;
  3980. dupnr:=0;
  3981. end;
  3982. procedure DoneSymtable;
  3983. begin
  3984. generrorsym.owner:=nil;
  3985. generrorsym.free;
  3986. generrordef.owner:=nil;
  3987. generrordef.free;
  3988. initialmacrosymtable.free;
  3989. macrosymtablestack.free;
  3990. {$ifdef UNITALIASES}
  3991. unitaliases.free;
  3992. {$endif}
  3993. end;
  3994. end.