symtable.pas 113 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120
  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,
  23. { global }
  24. cpuinfo,globtype,tokens,
  25. { symtable }
  26. symconst,symbase,symtype,symdef,symsym,
  27. { ppu }
  28. ppu,
  29. { assembler }
  30. aasmtai,aasmdata
  31. ;
  32. {****************************************************************************
  33. Symtable types
  34. ****************************************************************************}
  35. type
  36. tstoredsymtable = class(TSymtable)
  37. private
  38. b_needs_init_final : boolean;
  39. procedure _needs_init_final(sym:TObject;arg:pointer);
  40. procedure check_forward(sym:TObject;arg:pointer);
  41. procedure labeldefined(sym:TObject;arg:pointer);
  42. procedure varsymbolused(sym:TObject;arg:pointer);
  43. procedure TestPrivate(sym:TObject;arg:pointer);
  44. procedure objectprivatesymbolused(sym:TObject;arg:pointer);
  45. procedure loaddefs(ppufile:tcompilerppufile);
  46. procedure loadsyms(ppufile:tcompilerppufile);
  47. procedure writedefs(ppufile:tcompilerppufile);
  48. procedure writesyms(ppufile:tcompilerppufile);
  49. public
  50. procedure insert(sym:TSymEntry;checkdup:boolean=true);override;
  51. procedure delete(sym:TSymEntry);override;
  52. { load/write }
  53. procedure ppuload(ppufile:tcompilerppufile);virtual;
  54. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  55. procedure buildderef;virtual;
  56. procedure buildderefimpl;virtual;
  57. procedure deref;virtual;
  58. procedure derefimpl;virtual;
  59. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  60. procedure allsymbolsused;
  61. procedure allprivatesused;
  62. procedure check_forwards;
  63. procedure checklabels;
  64. function needs_init_final : boolean;
  65. procedure testfordefaultproperty(sym:TObject;arg:pointer);
  66. end;
  67. tabstractrecordsymtable = class(tstoredsymtable)
  68. public
  69. usefieldalignment, { alignment to use for fields (PACKRECORDS value), C_alignment is C style }
  70. recordalignment, { alignment desired when inserting this record }
  71. fieldalignment, { alignment current alignment used when fields are inserted }
  72. padalignment : shortint; { size to a multiple of which the symtable has to be rounded up }
  73. constructor create(const n:string;usealign:shortint);
  74. procedure ppuload(ppufile:tcompilerppufile);override;
  75. procedure ppuwrite(ppufile:tcompilerppufile);override;
  76. procedure alignrecord(fieldoffset:asizeint;varalign:shortint);
  77. procedure addfield(sym:tfieldvarsym;vis:tvisibility);
  78. procedure addalignmentpadding;
  79. procedure insertdef(def:TDefEntry);override;
  80. function is_packed: boolean;
  81. function has_single_field(out sym:tfieldvarsym): boolean;
  82. function get_unit_symtable: tsymtable;
  83. protected
  84. { size in bytes including padding }
  85. _datasize : asizeint;
  86. { size in bits of the data in case of bitpacked record. Only important during construction, }
  87. { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8. }
  88. databitsize : asizeint;
  89. { size in bytes of padding }
  90. _paddingsize : word;
  91. procedure setdatasize(val: asizeint);
  92. public
  93. function iscurrentunit: boolean; override;
  94. property datasize : asizeint read _datasize write setdatasize;
  95. property paddingsize: word read _paddingsize write _paddingsize;
  96. end;
  97. trecordsymtable = class(tabstractrecordsymtable)
  98. public
  99. constructor create(const n:string;usealign:shortint);
  100. procedure insertunionst(unionst : trecordsymtable;offset : longint);
  101. end;
  102. tObjectSymtable = class(tabstractrecordsymtable)
  103. public
  104. constructor create(adefowner:tdef;const n:string;usealign:shortint);
  105. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  106. end;
  107. { tabstractlocalsymtable }
  108. tabstractlocalsymtable = class(tstoredsymtable)
  109. public
  110. procedure ppuwrite(ppufile:tcompilerppufile);override;
  111. function count_locals:longint;
  112. end;
  113. tlocalsymtable = class(tabstractlocalsymtable)
  114. public
  115. constructor create(adefowner:tdef;level:byte);
  116. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  117. end;
  118. { tparasymtable }
  119. tparasymtable = class(tabstractlocalsymtable)
  120. public
  121. readonly: boolean;
  122. constructor create(adefowner:tdef;level:byte);
  123. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  124. procedure insertdef(def:TDefEntry);override;
  125. end;
  126. tabstractuniTSymtable = class(tstoredsymtable)
  127. public
  128. constructor create(const n : string;id:word);
  129. function iscurrentunit:boolean;override;
  130. end;
  131. tglobalsymtable = class(tabstractuniTSymtable)
  132. public
  133. unittypecount : word;
  134. constructor create(const n : string;id:word);
  135. procedure ppuload(ppufile:tcompilerppufile);override;
  136. procedure ppuwrite(ppufile:tcompilerppufile);override;
  137. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  138. end;
  139. tstaticsymtable = class(tabstractuniTSymtable)
  140. public
  141. constructor create(const n : string;id:word);
  142. procedure ppuload(ppufile:tcompilerppufile);override;
  143. procedure ppuwrite(ppufile:tcompilerppufile);override;
  144. function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
  145. end;
  146. twithsymtable = class(TSymtable)
  147. withrefnode : tobject; { tnode }
  148. constructor create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
  149. destructor destroy;override;
  150. procedure clear;override;
  151. procedure insertdef(def:TDefEntry);override;
  152. end;
  153. tstt_excepTSymtable = class(TSymtable)
  154. public
  155. constructor create;
  156. end;
  157. tmacrosymtable = class(tstoredsymtable)
  158. public
  159. constructor create(exported: boolean);
  160. end;
  161. { tenumsymtable }
  162. tenumsymtable = class(tstoredsymtable)
  163. public
  164. procedure insert(sym: TSymEntry; checkdup: boolean = true); override;
  165. constructor create(adefowner:tdef);
  166. end;
  167. { tarraysymtable }
  168. tarraysymtable = class(tstoredsymtable)
  169. public
  170. procedure insertdef(def:TDefEntry);override;
  171. constructor create(adefowner:tdef);
  172. end;
  173. var
  174. systemunit : tglobalsymtable; { pointer to the system unit }
  175. {****************************************************************************
  176. Functions
  177. ****************************************************************************}
  178. {*** Misc ***}
  179. function FullTypeName(def,otherdef:tdef):string;
  180. function generate_nested_name(symtable:tsymtable;delimiter:string):string;
  181. procedure incompatibletypes(def1,def2:tdef);
  182. procedure hidesym(sym:TSymEntry);
  183. procedure duplicatesym(var hashedid:THashedIDString;dupsym,origsym:TSymEntry);
  184. {*** Search ***}
  185. procedure addsymref(sym:tsym);
  186. function is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean;
  187. function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
  188. function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
  189. function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
  190. function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  191. function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  192. function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  193. function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
  194. function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
  195. function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  196. function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
  197. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
  198. { searches symbols inside of a helper's implementation }
  199. function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;aHasInherited:boolean):boolean;
  200. function search_system_type(const s: TIDString): ttypesym;
  201. function try_search_system_type(const s: TIDString): ttypesym;
  202. function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
  203. function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
  204. function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
  205. function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef;
  206. { searches for the helper definition that's currently active for pd }
  207. function search_last_objectpascal_helper(pd,contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
  208. { searches whether the symbol s is available in the currently active }
  209. { helper for pd }
  210. function search_objectpascal_helper(pd,contextclassh : tabstractrecorddef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  211. function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  212. function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  213. {Looks for macro s (must be given in upper case) in the macrosymbolstack, }
  214. {and returns it if found. Returns nil otherwise.}
  215. function search_macro(const s : string):tsym;
  216. { Additionally to searching for a macro, also checks whether it's still }
  217. { actually defined (could be disable using "undef") }
  218. function defined_macro(const s : string):boolean;
  219. {*** Object Helpers ***}
  220. function search_default_property(pd : tabstractrecorddef) : tpropertysym;
  221. function find_real_objcclass_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
  222. {*** Macro Helpers ***}
  223. {If called initially, the following procedures manipulate macros in }
  224. {initialmacrotable, otherwise they manipulate system macros local to a module.}
  225. {Name can be given in any case (it will be converted to upper case).}
  226. procedure def_system_macro(const name : string);
  227. procedure set_system_macro(const name, value : string);
  228. procedure set_system_compvar(const name, value : string);
  229. procedure undef_system_macro(const name : string);
  230. {*** symtable stack ***}
  231. { $ifdef DEBUG
  232. procedure test_symtablestack;
  233. procedure list_symtablestack;
  234. $endif DEBUG}
  235. {$ifdef UNITALIASES}
  236. type
  237. punit_alias = ^tunit_alias;
  238. tunit_alias = object(TNamedIndexItem)
  239. newname : pshortstring;
  240. constructor init(const n:string);
  241. destructor done;virtual;
  242. end;
  243. var
  244. unitaliases : pdictionary;
  245. procedure addunitalias(const n:string);
  246. function getunitalias(const n:string):string;
  247. {$endif UNITALIASES}
  248. {*** Init / Done ***}
  249. procedure IniTSymtable;
  250. procedure DoneSymtable;
  251. const
  252. overloaded_names : array [NOTOKEN..last_overloaded] of string[16] = (
  253. { NOTOKEN } 'error',
  254. { _PLUS } 'plus',
  255. { _MINUS } 'minus',
  256. { _STAR } 'star',
  257. { _SLASH } 'slash',
  258. { _EQ } 'equal',
  259. { _GT } 'greater',
  260. { _LT } 'lower',
  261. { _GTE } 'greater_or_equal',
  262. { _LTE } 'lower_or_equal',
  263. { _NE } 'not_equal',
  264. { _SYMDIF } 'sym_diff',
  265. { _STARSTAR } 'starstar',
  266. { _OP_AS } 'as',
  267. { _OP_IN } 'in',
  268. { _OP_IS } 'is',
  269. { _OP_OR } 'or',
  270. { _OP_AND } 'and',
  271. { _OP_DIV } 'div',
  272. { _OP_MOD } 'mod',
  273. { _OP_NOT } 'not',
  274. { _OP_SHL } 'shl',
  275. { _OP_SHR } 'shr',
  276. { _OP_XOR } 'xor',
  277. { _ASSIGNMENT } 'assign',
  278. { _OP_EXPLICIT } 'explicit',
  279. { _OP_ENUMERATOR } 'enumerator',
  280. { _OP_INC } 'inc',
  281. { _OP_DEC } 'dec');
  282. implementation
  283. uses
  284. { global }
  285. verbose,globals,
  286. { target }
  287. systems,
  288. { symtable }
  289. symutil,defcmp,defutil,
  290. { module }
  291. fmodule,
  292. { codegen }
  293. procinfo
  294. ;
  295. var
  296. dupnr : longint; { unique number for duplicate symbols }
  297. {*****************************************************************************
  298. TStoredSymtable
  299. *****************************************************************************}
  300. procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true);
  301. begin
  302. inherited insert(sym,checkdup);
  303. end;
  304. procedure tstoredsymtable.delete(sym:TSymEntry);
  305. begin
  306. inherited delete(sym);
  307. end;
  308. procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
  309. begin
  310. { load the table's flags }
  311. if ppufile.readentry<>ibsymtableoptions then
  312. Message(unit_f_ppu_read_error);
  313. ppufile.getsmallset(tableoptions);
  314. { load definitions }
  315. loaddefs(ppufile);
  316. { load symbols }
  317. loadsyms(ppufile);
  318. end;
  319. procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile);
  320. begin
  321. { write the table's flags }
  322. ppufile.putsmallset(tableoptions);
  323. ppufile.writeentry(ibsymtableoptions);
  324. { write definitions }
  325. writedefs(ppufile);
  326. { write symbols }
  327. writesyms(ppufile);
  328. end;
  329. procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile);
  330. var
  331. def : tdef;
  332. b : byte;
  333. begin
  334. { load start of definition section, which holds the amount of defs }
  335. if ppufile.readentry<>ibstartdefs then
  336. Message(unit_f_ppu_read_error);
  337. { read definitions }
  338. repeat
  339. b:=ppufile.readentry;
  340. case b of
  341. ibpointerdef : def:=tpointerdef.ppuload(ppufile);
  342. ibarraydef : def:=tarraydef.ppuload(ppufile);
  343. iborddef : def:=torddef.ppuload(ppufile);
  344. ibfloatdef : def:=tfloatdef.ppuload(ppufile);
  345. ibprocdef : def:=tprocdef.ppuload(ppufile);
  346. ibshortstringdef : def:=tstringdef.loadshort(ppufile);
  347. iblongstringdef : def:=tstringdef.loadlong(ppufile);
  348. ibansistringdef : def:=tstringdef.loadansi(ppufile);
  349. ibwidestringdef : def:=tstringdef.loadwide(ppufile);
  350. ibunicodestringdef : def:=tstringdef.loadunicode(ppufile);
  351. ibrecorddef : def:=trecorddef.ppuload(ppufile);
  352. ibobjectdef : def:=tobjectdef.ppuload(ppufile);
  353. ibenumdef : def:=tenumdef.ppuload(ppufile);
  354. ibsetdef : def:=tsetdef.ppuload(ppufile);
  355. ibprocvardef : def:=tprocvardef.ppuload(ppufile);
  356. ibfiledef : def:=tfiledef.ppuload(ppufile);
  357. ibclassrefdef : def:=tclassrefdef.ppuload(ppufile);
  358. ibformaldef : def:=tformaldef.ppuload(ppufile);
  359. ibvariantdef : def:=tvariantdef.ppuload(ppufile);
  360. ibundefineddef : def:=tundefineddef.ppuload(ppufile);
  361. ibenddefs : break;
  362. ibend : Message(unit_f_ppu_read_error);
  363. else
  364. Message1(unit_f_ppu_invalid_entry,tostr(b));
  365. end;
  366. InsertDef(def);
  367. until false;
  368. end;
  369. procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile);
  370. var
  371. b : byte;
  372. sym : tsym;
  373. begin
  374. { load start of definition section, which holds the amount of defs }
  375. if ppufile.readentry<>ibstartsyms then
  376. Message(unit_f_ppu_read_error);
  377. { now read the symbols }
  378. repeat
  379. b:=ppufile.readentry;
  380. case b of
  381. ibtypesym : sym:=ttypesym.ppuload(ppufile);
  382. ibprocsym : sym:=tprocsym.ppuload(ppufile);
  383. ibconstsym : sym:=tconstsym.ppuload(ppufile);
  384. ibstaticvarsym : sym:=tstaticvarsym.ppuload(ppufile);
  385. iblocalvarsym : sym:=tlocalvarsym.ppuload(ppufile);
  386. ibparavarsym : sym:=tparavarsym.ppuload(ppufile);
  387. ibfieldvarsym : sym:=tfieldvarsym.ppuload(ppufile);
  388. ibabsolutevarsym : sym:=tabsolutevarsym.ppuload(ppufile);
  389. ibenumsym : sym:=tenumsym.ppuload(ppufile);
  390. ibpropertysym : sym:=tpropertysym.ppuload(ppufile);
  391. ibunitsym : sym:=tunitsym.ppuload(ppufile);
  392. iblabelsym : sym:=tlabelsym.ppuload(ppufile);
  393. ibsyssym : sym:=tsyssym.ppuload(ppufile);
  394. ibmacrosym : sym:=tmacro.ppuload(ppufile);
  395. ibendsyms : break;
  396. ibend : Message(unit_f_ppu_read_error);
  397. else
  398. Message1(unit_f_ppu_invalid_entry,tostr(b));
  399. end;
  400. Insert(sym,false);
  401. until false;
  402. end;
  403. procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile);
  404. var
  405. i : longint;
  406. def : tstoreddef;
  407. begin
  408. { each definition get a number, write then the amount of defs to the
  409. ibstartdef entry }
  410. ppufile.putlongint(DefList.count);
  411. ppufile.writeentry(ibstartdefs);
  412. { now write the definition }
  413. for i:=0 to DefList.Count-1 do
  414. begin
  415. def:=tstoreddef(DefList[i]);
  416. def.ppuwrite(ppufile);
  417. end;
  418. { write end of definitions }
  419. ppufile.writeentry(ibenddefs);
  420. end;
  421. procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile);
  422. var
  423. i : longint;
  424. sym : Tstoredsym;
  425. begin
  426. { each definition get a number, write then the amount of syms and the
  427. datasize to the ibsymdef entry }
  428. ppufile.putlongint(SymList.count);
  429. ppufile.writeentry(ibstartsyms);
  430. { foreach is used to write all symbols }
  431. for i:=0 to SymList.Count-1 do
  432. begin
  433. sym:=tstoredsym(SymList[i]);
  434. sym.ppuwrite(ppufile);
  435. end;
  436. { end of symbols }
  437. ppufile.writeentry(ibendsyms);
  438. end;
  439. procedure tstoredsymtable.buildderef;
  440. var
  441. i : longint;
  442. def : tstoreddef;
  443. sym : tstoredsym;
  444. begin
  445. { interface definitions }
  446. for i:=0 to DefList.Count-1 do
  447. begin
  448. def:=tstoreddef(DefList[i]);
  449. def.buildderef;
  450. end;
  451. { interface symbols }
  452. for i:=0 to SymList.Count-1 do
  453. begin
  454. sym:=tstoredsym(SymList[i]);
  455. sym.buildderef;
  456. end;
  457. end;
  458. procedure tstoredsymtable.buildderefimpl;
  459. var
  460. i : longint;
  461. def : tstoreddef;
  462. begin
  463. { implementation definitions }
  464. for i:=0 to DefList.Count-1 do
  465. begin
  466. def:=tstoreddef(DefList[i]);
  467. def.buildderefimpl;
  468. end;
  469. end;
  470. procedure tstoredsymtable.deref;
  471. var
  472. i : longint;
  473. def : tstoreddef;
  474. sym : tstoredsym;
  475. begin
  476. { first deref the interface ttype symbols. This is needs
  477. to be done before the interface defs are derefed, because
  478. the interface defs can contain references to the type symbols
  479. which then already need to contain a resolved typedef field (PFV) }
  480. for i:=0 to SymList.Count-1 do
  481. begin
  482. sym:=tstoredsym(SymList[i]);
  483. if sym.typ=typesym then
  484. sym.deref;
  485. end;
  486. { interface definitions }
  487. for i:=0 to DefList.Count-1 do
  488. begin
  489. def:=tstoreddef(DefList[i]);
  490. def.deref;
  491. end;
  492. { interface symbols }
  493. for i:=0 to SymList.Count-1 do
  494. begin
  495. sym:=tstoredsym(SymList[i]);
  496. if sym.typ<>typesym then
  497. sym.deref;
  498. end;
  499. end;
  500. procedure tstoredsymtable.derefimpl;
  501. var
  502. i : longint;
  503. def : tstoreddef;
  504. begin
  505. { implementation definitions }
  506. for i:=0 to DefList.Count-1 do
  507. begin
  508. def:=tstoreddef(DefList[i]);
  509. def.derefimpl;
  510. end;
  511. end;
  512. function tstoredsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  513. var
  514. hsym : tsym;
  515. begin
  516. hsym:=tsym(FindWithHash(hashedid));
  517. if assigned(hsym) then
  518. DuplicateSym(hashedid,sym,hsym);
  519. result:=assigned(hsym);
  520. end;
  521. {**************************************
  522. Callbacks
  523. **************************************}
  524. procedure TStoredSymtable.check_forward(sym:TObject;arg:pointer);
  525. begin
  526. if tsym(sym).typ=procsym then
  527. tprocsym(sym).check_forward
  528. { check also object method table }
  529. { we needn't to test the def list }
  530. { because each object has to have a type sym,
  531. only test objects declarations, not type renamings }
  532. else
  533. if (tsym(sym).typ=typesym) and
  534. assigned(ttypesym(sym).typedef) and
  535. (ttypesym(sym).typedef.typesym=ttypesym(sym)) and
  536. (ttypesym(sym).typedef.typ in [objectdef,recorddef]) then
  537. tabstractrecorddef(ttypesym(sym).typedef).check_forwards;
  538. end;
  539. procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer);
  540. begin
  541. if (tsym(sym).typ=labelsym) and
  542. not(tlabelsym(sym).defined) then
  543. begin
  544. if tlabelsym(sym).used then
  545. Message1(sym_e_label_used_and_not_defined,tlabelsym(sym).realname)
  546. else
  547. Message1(sym_w_label_not_defined,tlabelsym(sym).realname);
  548. end;
  549. end;
  550. procedure TStoredSymtable.varsymbolused(sym:TObject;arg:pointer);
  551. begin
  552. if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and
  553. ((tsym(sym).owner.symtabletype in
  554. [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then
  555. begin
  556. { unused symbol should be reported only if no }
  557. { error is reported }
  558. { if the symbol is in a register it is used }
  559. { also don't count the value parameters which have local copies }
  560. { also don't claim for high param of open parameters (PM) }
  561. { also don't complain about unused symbols in generic procedures }
  562. { and methods }
  563. if (Errorcount<>0) or
  564. ([vo_is_hidden_para,vo_is_funcret] * tabstractvarsym(sym).varoptions = [vo_is_hidden_para]) or
  565. (sp_internal in tsym(sym).symoptions) or
  566. ((assigned(tsym(sym).owner.defowner) and
  567. (tsym(sym).owner.defowner.typ=procdef) and
  568. (df_generic in tprocdef(tsym(sym).owner.defowner).defoptions))) then
  569. exit;
  570. if (tstoredsym(sym).refs=0) then
  571. begin
  572. if (vo_is_funcret in tabstractvarsym(sym).varoptions) then
  573. begin
  574. { don't warn about the result of constructors }
  575. if ((tsym(sym).owner.symtabletype<>localsymtable) or
  576. (tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and
  577. not(cs_opt_nodedfa in current_settings.optimizerswitches) then
  578. MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set)
  579. end
  580. else if (tsym(sym).owner.symtabletype=parasymtable) then
  581. MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname)
  582. else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  583. MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
  584. else
  585. MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname);
  586. end
  587. else if tabstractvarsym(sym).varstate in [vs_written,vs_initialised] then
  588. begin
  589. if (tsym(sym).owner.symtabletype=parasymtable) then
  590. begin
  591. if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and
  592. not(vo_is_funcret in tabstractvarsym(sym).varoptions) then
  593. MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname)
  594. end
  595. else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  596. MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
  597. else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then
  598. MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname);
  599. end
  600. else if (tabstractvarsym(sym).varstate = vs_read_not_warned) and
  601. ([vo_is_public,vo_is_external] * tabstractvarsym(sym).varoptions = []) then
  602. MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname)
  603. end
  604. else if ((tsym(sym).owner.symtabletype in
  605. [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then
  606. begin
  607. if (Errorcount<>0) or
  608. (sp_internal in tsym(sym).symoptions) then
  609. exit;
  610. { do not claim for inherited private fields !! }
  611. if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  612. case tsym(sym).typ of
  613. typesym:
  614. MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  615. constsym:
  616. MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  617. propertysym:
  618. MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  619. else
  620. MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
  621. end
  622. { units references are problematic }
  623. else
  624. begin
  625. if (tsym(sym).refs=0) and
  626. not(tsym(sym).typ in [enumsym,unitsym]) and
  627. not(is_funcret_sym(tsym(sym))) and
  628. { don't complain about compiler generated syms for specializations, see also #13405 }
  629. not((tsym(sym).typ=typesym) and (df_specialization in ttypesym(sym).typedef.defoptions) and
  630. (pos('$',ttypesym(sym).Realname)<>0)) and
  631. (
  632. (tsym(sym).typ<>procsym) or
  633. ((tsym(sym).owner.symtabletype=staticsymtable) and
  634. not current_module.is_unit)
  635. ) and
  636. { don't complain about alias for hidden _cmd parameter to
  637. obj-c methods }
  638. not((tsym(sym).typ in [localvarsym,paravarsym,absolutevarsym]) and
  639. (vo_is_msgsel in tabstractvarsym(sym).varoptions)) then
  640. MessagePos2(tsym(sym).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(sym).typ],tsym(sym).prettyname);
  641. end;
  642. end;
  643. end;
  644. procedure TStoredSymtable.TestPrivate(sym:TObject;arg:pointer);
  645. begin
  646. if tsym(sym).visibility in [vis_private,vis_strictprivate] then
  647. varsymbolused(sym,arg);
  648. end;
  649. procedure TStoredSymtable.objectprivatesymbolused(sym:TObject;arg:pointer);
  650. begin
  651. {
  652. Don't test simple object aliases PM
  653. }
  654. if (tsym(sym).typ=typesym) and
  655. (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and
  656. (ttypesym(sym).typedef.typesym=tsym(sym)) then
  657. tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil);
  658. end;
  659. procedure tstoredsymtable.testfordefaultproperty(sym:TObject;arg:pointer);
  660. begin
  661. if (tsym(sym).typ=propertysym) and
  662. (ppo_defaultproperty in tpropertysym(sym).propoptions) then
  663. ppointer(arg)^:=sym;
  664. end;
  665. {***********************************************
  666. Process all entries
  667. ***********************************************}
  668. { checks, if all procsyms and methods are defined }
  669. procedure tstoredsymtable.check_forwards;
  670. begin
  671. SymList.ForEachCall(@check_forward,nil);
  672. end;
  673. procedure tstoredsymtable.checklabels;
  674. begin
  675. SymList.ForEachCall(@labeldefined,nil);
  676. end;
  677. procedure tstoredsymtable.allsymbolsused;
  678. begin
  679. SymList.ForEachCall(@varsymbolused,nil);
  680. end;
  681. procedure tstoredsymtable.allprivatesused;
  682. begin
  683. SymList.ForEachCall(@objectprivatesymbolused,nil);
  684. end;
  685. procedure TStoredSymtable._needs_init_final(sym:TObject;arg:pointer);
  686. begin
  687. if b_needs_init_final then
  688. exit;
  689. { don't check static symbols - they can be present in structures only and
  690. always have a reference to a symbol defined on unit level }
  691. if sp_static in tsym(sym).symoptions then
  692. exit;
  693. case tsym(sym).typ of
  694. fieldvarsym,
  695. staticvarsym,
  696. localvarsym,
  697. paravarsym :
  698. begin
  699. if is_managed_type(tabstractvarsym(sym).vardef) then
  700. b_needs_init_final:=true;
  701. end;
  702. end;
  703. end;
  704. { returns true, if p contains data which needs init/final code }
  705. function tstoredsymtable.needs_init_final : boolean;
  706. begin
  707. b_needs_init_final:=false;
  708. SymList.ForEachCall(@_needs_init_final,nil);
  709. needs_init_final:=b_needs_init_final;
  710. end;
  711. {****************************************************************************
  712. TAbstractRecordSymtable
  713. ****************************************************************************}
  714. constructor tabstractrecordsymtable.create(const n:string;usealign:shortint);
  715. begin
  716. inherited create(n);
  717. moduleid:=current_module.moduleid;
  718. _datasize:=0;
  719. databitsize:=0;
  720. recordalignment:=1;
  721. usefieldalignment:=usealign;
  722. padalignment:=1;
  723. { recordalign C_alignment means C record packing, that starts
  724. with an alignment of 1 }
  725. case usealign of
  726. C_alignment,
  727. bit_alignment:
  728. fieldalignment:=1;
  729. mac68k_alignment:
  730. fieldalignment:=2;
  731. else
  732. fieldalignment:=usealign;
  733. end;
  734. end;
  735. procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile);
  736. begin
  737. if ppufile.readentry<>ibrecsymtableoptions then
  738. Message(unit_f_ppu_read_error);
  739. recordalignment:=shortint(ppufile.getbyte);
  740. usefieldalignment:=shortint(ppufile.getbyte);
  741. if (usefieldalignment=C_alignment) then
  742. fieldalignment:=shortint(ppufile.getbyte);
  743. inherited ppuload(ppufile);
  744. end;
  745. procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile);
  746. var
  747. oldtyp : byte;
  748. begin
  749. oldtyp:=ppufile.entrytyp;
  750. ppufile.entrytyp:=subentryid;
  751. { in case of classes using C alignment, the alignment of the parent
  752. affects the alignment of fields of the childs }
  753. ppufile.putbyte(byte(recordalignment));
  754. ppufile.putbyte(byte(usefieldalignment));
  755. if (usefieldalignment=C_alignment) then
  756. ppufile.putbyte(byte(fieldalignment));
  757. ppufile.writeentry(ibrecsymtableoptions);
  758. inherited ppuwrite(ppufile);
  759. ppufile.entrytyp:=oldtyp;
  760. end;
  761. function field2recordalignment(fieldoffs, fieldalign: asizeint): asizeint;
  762. begin
  763. { optimal alignment of the record when declaring a variable of this }
  764. { type is independent of the packrecords setting }
  765. if (fieldoffs mod fieldalign) = 0 then
  766. result:=fieldalign
  767. else if (fieldalign >= 16) and
  768. ((fieldoffs mod 16) = 0) and
  769. ((fieldalign mod 16) = 0) then
  770. result:=16
  771. else if (fieldalign >= 8) and
  772. ((fieldoffs mod 8) = 0) and
  773. ((fieldalign mod 8) = 0) then
  774. result:=8
  775. else if (fieldalign >= 4) and
  776. ((fieldoffs mod 4) = 0) and
  777. ((fieldalign mod 4) = 0) then
  778. result:=4
  779. else if (fieldalign >= 2) and
  780. ((fieldoffs mod 2) = 0) and
  781. ((fieldalign mod 2) = 0) then
  782. result:=2
  783. else
  784. result:=1;
  785. end;
  786. procedure tabstractrecordsymtable.alignrecord(fieldoffset:asizeint;varalign:shortint);
  787. var
  788. varalignrecord: shortint;
  789. begin
  790. case usefieldalignment of
  791. C_alignment:
  792. varalignrecord:=used_align(varalign,current_settings.alignment.recordalignmin,current_settings.alignment.maxCrecordalign);
  793. mac68k_alignment:
  794. varalignrecord:=2;
  795. else
  796. varalignrecord:=field2recordalignment(fieldoffset,varalign);
  797. end;
  798. recordalignment:=max(recordalignment,varalignrecord);
  799. end;
  800. procedure tabstractrecordsymtable.addfield(sym:tfieldvarsym;vis:tvisibility);
  801. var
  802. l : asizeint;
  803. varalignfield,
  804. varalign : shortint;
  805. vardef : tdef;
  806. begin
  807. if (sym.owner<>self) then
  808. internalerror(200602031);
  809. if sym.fieldoffset<>-1 then
  810. internalerror(200602032);
  811. { set visibility for the symbol }
  812. sym.visibility:=vis;
  813. { this symbol can't be loaded to a register }
  814. sym.varregable:=vr_none;
  815. { Calculate field offset }
  816. l:=sym.getsize;
  817. vardef:=sym.vardef;
  818. varalign:=vardef.alignment;
  819. case usefieldalignment of
  820. bit_alignment:
  821. begin
  822. { bitpacking only happens for ordinals, the rest is aligned at }
  823. { 1 byte (compatible with GPC/GCC) }
  824. if is_ordinal(vardef) then
  825. begin
  826. sym.fieldoffset:=databitsize;
  827. l:=sym.getpackedbitsize;
  828. end
  829. else
  830. begin
  831. databitsize:=_datasize*8;
  832. sym.fieldoffset:=databitsize;
  833. if (l>high(asizeint) div 8) then
  834. Message(sym_e_segment_too_large);
  835. l:=l*8;
  836. end;
  837. if varalign=0 then
  838. varalign:=size_2_align(l);
  839. recordalignment:=max(recordalignment,field2recordalignment(databitsize mod 8,varalign));
  840. { bit packed records are limited to high(aint) bits }
  841. { instead of bytes to avoid double precision }
  842. { arithmetic in offset calculations }
  843. if int64(l)>high(asizeint)-sym.fieldoffset then
  844. begin
  845. Message(sym_e_segment_too_large);
  846. _datasize:=high(asizeint);
  847. databitsize:=high(asizeint);
  848. end
  849. else
  850. begin
  851. databitsize:=sym.fieldoffset+l;
  852. _datasize:=(databitsize+7) div 8;
  853. end;
  854. { rest is not applicable }
  855. exit;
  856. end;
  857. { Calc the alignment size for C style records }
  858. C_alignment:
  859. begin
  860. if (varalign>4) and
  861. ((varalign mod 4)<>0) and
  862. (vardef.typ=arraydef) then
  863. Message1(sym_w_wrong_C_pack,vardef.typename);
  864. if varalign=0 then
  865. varalign:=l;
  866. if (fieldalignment<current_settings.alignment.maxCrecordalign) then
  867. begin
  868. if (varalign>16) and (fieldalignment<32) then
  869. fieldalignment:=32
  870. else if (varalign>12) and (fieldalignment<16) then
  871. fieldalignment:=16
  872. { 12 is needed for long double }
  873. else if (varalign>8) and (fieldalignment<12) then
  874. fieldalignment:=12
  875. else if (varalign>4) and (fieldalignment<8) then
  876. fieldalignment:=8
  877. else if (varalign>2) and (fieldalignment<4) then
  878. fieldalignment:=4
  879. else if (varalign>1) and (fieldalignment<2) then
  880. fieldalignment:=2;
  881. end;
  882. fieldalignment:=min(fieldalignment,current_settings.alignment.maxCrecordalign);
  883. end;
  884. mac68k_alignment:
  885. begin
  886. { mac68k alignment (C description):
  887. * char is aligned to 1 byte
  888. * everything else (except vector) is aligned to 2 bytes
  889. * vector is aligned to 16 bytes
  890. }
  891. if l>1 then
  892. fieldalignment:=2
  893. else
  894. fieldalignment:=1;
  895. varalign:=2;
  896. end;
  897. end;
  898. if varalign=0 then
  899. varalign:=size_2_align(l);
  900. varalignfield:=used_align(varalign,current_settings.alignment.recordalignmin,fieldalignment);
  901. sym.fieldoffset:=align(_datasize,varalignfield);
  902. if l>high(asizeint)-sym.fieldoffset then
  903. begin
  904. Message(sym_e_segment_too_large);
  905. _datasize:=high(aint);
  906. end
  907. else
  908. _datasize:=sym.fieldoffset+l;
  909. { Calc alignment needed for this record }
  910. alignrecord(sym.fieldoffset,varalign);
  911. end;
  912. procedure tabstractrecordsymtable.addalignmentpadding;
  913. var
  914. padded_datasize: asizeint;
  915. begin
  916. { make the record size aligned correctly so it can be
  917. used as elements in an array. For C records we
  918. use the fieldalignment, because that is updated with the
  919. used alignment. }
  920. if (padalignment = 1) then
  921. case usefieldalignment of
  922. C_alignment:
  923. padalignment:=fieldalignment;
  924. { bitpacked }
  925. bit_alignment:
  926. padalignment:=1;
  927. { mac68k: always round to multiple of 2 }
  928. mac68k_alignment:
  929. padalignment:=2;
  930. { default/no packrecords specified }
  931. 0:
  932. padalignment:=recordalignment
  933. { specific packrecords setting -> use as upper limit }
  934. else
  935. padalignment:=min(recordalignment,usefieldalignment);
  936. end;
  937. padded_datasize:=align(_datasize,padalignment);
  938. _paddingsize:=padded_datasize-_datasize;
  939. _datasize:=padded_datasize;
  940. end;
  941. procedure tabstractrecordsymtable.insertdef(def:TDefEntry);
  942. begin
  943. { Enums must also be available outside the record scope,
  944. insert in the owner of this symtable }
  945. if def.typ=enumdef then
  946. defowner.owner.insertdef(def)
  947. else
  948. inherited insertdef(def);
  949. end;
  950. function tabstractrecordsymtable.is_packed: boolean;
  951. begin
  952. result:=usefieldalignment=bit_alignment;
  953. end;
  954. function tabstractrecordsymtable.has_single_field(out sym: tfieldvarsym): boolean;
  955. var
  956. i: longint;
  957. begin
  958. result:=false;
  959. { If a record contains a union, it does not contain a "single
  960. non-composite field" in the context of certain ABIs requiring
  961. special treatment for such records }
  962. if (defowner.typ=recorddef) and
  963. trecorddef(defowner).isunion then
  964. exit;
  965. { a record/object can contain other things than fields }
  966. for i:=0 to SymList.Count-1 do
  967. begin
  968. if tsym(symlist[i]).typ=fieldvarsym then
  969. begin
  970. if result then
  971. begin
  972. result:=false;
  973. exit;
  974. end;
  975. result:=true;
  976. sym:=tfieldvarsym(symlist[i])
  977. end;
  978. end;
  979. end;
  980. function tabstractrecordsymtable.get_unit_symtable: tsymtable;
  981. begin
  982. result:=defowner.owner;
  983. while assigned(result) and (result.symtabletype in [ObjectSymtable,recordsymtable]) do
  984. result:=result.defowner.owner;
  985. end;
  986. procedure tabstractrecordsymtable.setdatasize(val: asizeint);
  987. begin
  988. _datasize:=val;
  989. if (usefieldalignment=bit_alignment) then
  990. { can overflow in non bitpacked records }
  991. databitsize:=val*8;
  992. end;
  993. function tabstractrecordsymtable.iscurrentunit: boolean;
  994. begin
  995. Result := Assigned(current_module) and (current_module.moduleid=moduleid);
  996. end;
  997. {****************************************************************************
  998. TRecordSymtable
  999. ****************************************************************************}
  1000. constructor trecordsymtable.create(const n:string;usealign:shortint);
  1001. begin
  1002. inherited create(n,usealign);
  1003. symtabletype:=recordsymtable;
  1004. end;
  1005. { this procedure is reserved for inserting case variant into
  1006. a record symtable }
  1007. { the offset is the location of the start of the variant
  1008. and datasize and dataalignment corresponds to
  1009. the complete size (see code in pdecl unit) PM }
  1010. procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : longint);
  1011. var
  1012. sym : tsym;
  1013. def : tdef;
  1014. i : integer;
  1015. varalignrecord,varalign,
  1016. storesize,storealign : aint;
  1017. bitsize: aint;
  1018. begin
  1019. storesize:=_datasize;
  1020. storealign:=fieldalignment;
  1021. _datasize:=offset;
  1022. if (usefieldalignment=bit_alignment) then
  1023. databitsize:=offset*8;
  1024. { We move the ownership of the defs and symbols to the new recordsymtable.
  1025. The old unionsymtable keeps the references, but doesn't own the
  1026. objects anymore }
  1027. unionst.DefList.OwnsObjects:=false;
  1028. unionst.SymList.OwnsObjects:=false;
  1029. { copy symbols }
  1030. for i:=0 to unionst.SymList.Count-1 do
  1031. begin
  1032. sym:=TSym(unionst.SymList[i]);
  1033. if sym.typ<>fieldvarsym then
  1034. internalerror(200601272);
  1035. if tfieldvarsym(sym).fieldoffset=0 then
  1036. include(tfieldvarsym(sym).varoptions,vo_is_first_field);
  1037. { add to this record symtable }
  1038. // unionst.SymList.List.List^[i].Data:=nil;
  1039. sym.ChangeOwner(self);
  1040. varalign:=tfieldvarsym(sym).vardef.alignment;
  1041. if varalign=0 then
  1042. varalign:=size_2_align(tfieldvarsym(sym).getsize);
  1043. { retrieve size }
  1044. if (usefieldalignment=bit_alignment) then
  1045. begin
  1046. { bit packed records are limited to high(aint) bits }
  1047. { instead of bytes to avoid double precision }
  1048. { arithmetic in offset calculations }
  1049. if is_ordinal(tfieldvarsym(sym).vardef) then
  1050. bitsize:=tfieldvarsym(sym).getpackedbitsize
  1051. else
  1052. begin
  1053. bitsize:=tfieldvarsym(sym).getsize;
  1054. if (bitsize>high(asizeint) div 8) then
  1055. Message(sym_e_segment_too_large);
  1056. bitsize:=bitsize*8;
  1057. end;
  1058. if bitsize>high(asizeint)-databitsize then
  1059. begin
  1060. Message(sym_e_segment_too_large);
  1061. _datasize:=high(aint);
  1062. databitsize:=high(aint);
  1063. end
  1064. else
  1065. begin
  1066. databitsize:=tfieldvarsym(sym).fieldoffset+offset*8;
  1067. _datasize:=(databitsize+7) div 8;
  1068. end;
  1069. tfieldvarsym(sym).fieldoffset:=databitsize;
  1070. varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset div 8,varalign);
  1071. end
  1072. else
  1073. begin
  1074. if tfieldvarsym(sym).getsize>high(asizeint)-_datasize then
  1075. begin
  1076. Message(sym_e_segment_too_large);
  1077. _datasize:=high(aint);
  1078. end
  1079. else
  1080. _datasize:=tfieldvarsym(sym).fieldoffset+offset;
  1081. { update address }
  1082. tfieldvarsym(sym).fieldoffset:=_datasize;
  1083. varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset,varalign);
  1084. end;
  1085. { update alignment of this record }
  1086. if (usefieldalignment<>C_alignment) and
  1087. (usefieldalignment<>mac68k_alignment) then
  1088. recordalignment:=max(recordalignment,varalignrecord);
  1089. end;
  1090. { update alignment for C records }
  1091. if (usefieldalignment=C_alignment) and
  1092. (usefieldalignment<>mac68k_alignment) then
  1093. recordalignment:=max(recordalignment,unionst.recordalignment);
  1094. { Register defs in the new record symtable }
  1095. for i:=0 to unionst.DefList.Count-1 do
  1096. begin
  1097. def:=TDef(unionst.DefList[i]);
  1098. def.ChangeOwner(self);
  1099. end;
  1100. _datasize:=storesize;
  1101. fieldalignment:=storealign;
  1102. { If a record contains a union, it does not contain a "single
  1103. non-composite field" in the context of certain ABIs requiring
  1104. special treatment for such records }
  1105. if defowner.typ=recorddef then
  1106. trecorddef(defowner).isunion:=true;
  1107. end;
  1108. {****************************************************************************
  1109. TObjectSymtable
  1110. ****************************************************************************}
  1111. constructor tObjectSymtable.create(adefowner:tdef;const n:string;usealign:shortint);
  1112. begin
  1113. inherited create(n,usealign);
  1114. symtabletype:=ObjectSymtable;
  1115. defowner:=adefowner;
  1116. end;
  1117. function tObjectSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1118. var
  1119. hsym : tsym;
  1120. begin
  1121. result:=false;
  1122. if not assigned(defowner) then
  1123. internalerror(200602061);
  1124. { procsym and propertysym have special code
  1125. to override values in inherited classes. For other
  1126. symbols check for duplicates }
  1127. if not(sym.typ in [procsym,propertysym]) then
  1128. begin
  1129. { but private ids can be reused }
  1130. hsym:=search_struct_member(tobjectdef(defowner),hashedid.id);
  1131. if assigned(hsym) and
  1132. (
  1133. (
  1134. not(m_delphi in current_settings.modeswitches) and
  1135. is_visible_for_object(hsym,tobjectdef(defowner))
  1136. ) or
  1137. (
  1138. { In Delphi, you can repeat members of a parent class. You can't }
  1139. { do this for objects however, and you (obviouly) can't }
  1140. { declare two fields with the same name in a single class }
  1141. (m_delphi in current_settings.modeswitches) and
  1142. (
  1143. is_object(tdef(defowner)) or
  1144. (hsym.owner = self)
  1145. )
  1146. )
  1147. ) then
  1148. begin
  1149. DuplicateSym(hashedid,sym,hsym);
  1150. result:=true;
  1151. end;
  1152. end
  1153. else
  1154. begin
  1155. if not(m_duplicate_names in current_settings.modeswitches) then
  1156. result:=inherited checkduplicate(hashedid,sym);
  1157. end;
  1158. end;
  1159. {****************************************************************************
  1160. TAbstractLocalSymtable
  1161. ****************************************************************************}
  1162. procedure tabstractlocalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1163. var
  1164. oldtyp : byte;
  1165. begin
  1166. oldtyp:=ppufile.entrytyp;
  1167. ppufile.entrytyp:=subentryid;
  1168. inherited ppuwrite(ppufile);
  1169. ppufile.entrytyp:=oldtyp;
  1170. end;
  1171. function tabstractlocalsymtable.count_locals:longint;
  1172. var
  1173. i : longint;
  1174. sym : tsym;
  1175. begin
  1176. result:=0;
  1177. for i:=0 to SymList.Count-1 do
  1178. begin
  1179. sym:=tsym(SymList[i]);
  1180. { Count only varsyms, but ignore the funcretsym }
  1181. if (tsym(sym).typ in [localvarsym,paravarsym]) and
  1182. (tsym(sym)<>current_procinfo.procdef.funcretsym) and
  1183. (not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or
  1184. (tstoredsym(sym).refs>0)) then
  1185. inc(result);
  1186. end;
  1187. end;
  1188. {****************************************************************************
  1189. TLocalSymtable
  1190. ****************************************************************************}
  1191. constructor tlocalsymtable.create(adefowner:tdef;level:byte);
  1192. begin
  1193. inherited create('');
  1194. defowner:=adefowner;
  1195. symtabletype:=localsymtable;
  1196. symtablelevel:=level;
  1197. end;
  1198. function tlocalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1199. var
  1200. hsym : tsym;
  1201. begin
  1202. if not assigned(defowner) or
  1203. (defowner.typ<>procdef) then
  1204. internalerror(200602042);
  1205. result:=false;
  1206. hsym:=tsym(FindWithHash(hashedid));
  1207. if assigned(hsym) then
  1208. begin
  1209. { a local and the function can have the same
  1210. name in TP and Delphi, but RESULT not }
  1211. if (m_duplicate_names in current_settings.modeswitches) and
  1212. (hsym.typ in [absolutevarsym,localvarsym]) and
  1213. (vo_is_funcret in tabstractvarsym(hsym).varoptions) and
  1214. not((m_result in current_settings.modeswitches) and
  1215. (vo_is_result in tabstractvarsym(hsym).varoptions)) then
  1216. HideSym(hsym)
  1217. else
  1218. DuplicateSym(hashedid,sym,hsym);
  1219. result:=true;
  1220. exit;
  1221. end;
  1222. { check also parasymtable, this needs to be done here because
  1223. of the special situation with the funcret sym that needs to be
  1224. hidden for tp and delphi modes }
  1225. hsym:=tsym(tabstractprocdef(defowner).parast.FindWithHash(hashedid));
  1226. if assigned(hsym) then
  1227. begin
  1228. { a local and the function can have the same
  1229. name in TP and Delphi, but RESULT not }
  1230. if (m_duplicate_names in current_settings.modeswitches) and
  1231. (sym.typ in [absolutevarsym,localvarsym]) and
  1232. (vo_is_funcret in tabstractvarsym(sym).varoptions) and
  1233. not((m_result in current_settings.modeswitches) and
  1234. (vo_is_result in tabstractvarsym(sym).varoptions)) then
  1235. Hidesym(sym)
  1236. else
  1237. DuplicateSym(hashedid,sym,hsym);
  1238. result:=true;
  1239. exit;
  1240. end;
  1241. { check ObjectSymtable, skip this for funcret sym because
  1242. that will always be positive because it has the same name
  1243. as the procsym }
  1244. if not is_funcret_sym(sym) and
  1245. (defowner.typ=procdef) and
  1246. assigned(tprocdef(defowner).struct) and
  1247. (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
  1248. (
  1249. not(m_delphi in current_settings.modeswitches) or
  1250. is_object(tprocdef(defowner).struct)
  1251. ) then
  1252. result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
  1253. end;
  1254. {****************************************************************************
  1255. TParaSymtable
  1256. ****************************************************************************}
  1257. constructor tparasymtable.create(adefowner:tdef;level:byte);
  1258. begin
  1259. inherited create('');
  1260. readonly:=false;
  1261. defowner:=adefowner;
  1262. symtabletype:=parasymtable;
  1263. symtablelevel:=level;
  1264. end;
  1265. function tparasymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1266. begin
  1267. result:=inherited checkduplicate(hashedid,sym);
  1268. if result then
  1269. exit;
  1270. if not(m_duplicate_names in current_settings.modeswitches) and
  1271. (defowner.typ=procdef) and
  1272. assigned(tprocdef(defowner).struct) and
  1273. (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
  1274. (
  1275. not(m_delphi in current_settings.modeswitches) or
  1276. is_object(tprocdef(defowner).struct)
  1277. ) then
  1278. result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
  1279. end;
  1280. procedure tparasymtable.insertdef(def: TDefEntry);
  1281. begin
  1282. if readonly then
  1283. defowner.owner.insertdef(def)
  1284. else
  1285. inherited insertdef(def);
  1286. end;
  1287. {****************************************************************************
  1288. TAbstractUniTSymtable
  1289. ****************************************************************************}
  1290. constructor tabstractuniTSymtable.create(const n : string;id:word);
  1291. begin
  1292. inherited create(n);
  1293. moduleid:=id;
  1294. end;
  1295. function tabstractuniTSymtable.iscurrentunit:boolean;
  1296. begin
  1297. result:=assigned(current_module) and
  1298. (
  1299. (current_module.globalsymtable=self) or
  1300. (current_module.localsymtable=self)
  1301. );
  1302. end;
  1303. {****************************************************************************
  1304. TStaticSymtable
  1305. ****************************************************************************}
  1306. constructor tstaticsymtable.create(const n : string;id:word);
  1307. begin
  1308. inherited create(n,id);
  1309. symtabletype:=staticsymtable;
  1310. symtablelevel:=main_program_level;
  1311. end;
  1312. procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile);
  1313. begin
  1314. inherited ppuload(ppufile);
  1315. { now we can deref the syms and defs }
  1316. deref;
  1317. end;
  1318. procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile);
  1319. begin
  1320. inherited ppuwrite(ppufile);
  1321. end;
  1322. function tstaticsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1323. var
  1324. hsym : tsym;
  1325. begin
  1326. result:=false;
  1327. hsym:=tsym(FindWithHash(hashedid));
  1328. if assigned(hsym) then
  1329. begin
  1330. { Delphi (contrary to TP) you can have a symbol with the same name as the
  1331. unit, the unit can then not be accessed anymore using
  1332. <unit>.<id>, so we can hide the symbol }
  1333. if (m_delphi in current_settings.modeswitches) and
  1334. (hsym.typ=symconst.unitsym) then
  1335. HideSym(hsym)
  1336. else
  1337. DuplicateSym(hashedid,sym,hsym);
  1338. result:=true;
  1339. exit;
  1340. end;
  1341. if (current_module.localsymtable=self) and
  1342. assigned(current_module.globalsymtable) then
  1343. result:=tglobalsymtable(current_module.globalsymtable).checkduplicate(hashedid,sym);
  1344. end;
  1345. {****************************************************************************
  1346. TGlobalSymtable
  1347. ****************************************************************************}
  1348. constructor tglobalsymtable.create(const n : string;id:word);
  1349. begin
  1350. inherited create(n,id);
  1351. symtabletype:=globalsymtable;
  1352. symtablelevel:=main_program_level;
  1353. end;
  1354. procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile);
  1355. begin
  1356. inherited ppuload(ppufile);
  1357. { now we can deref the syms and defs }
  1358. deref;
  1359. end;
  1360. procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1361. begin
  1362. { write the symtable entries }
  1363. inherited ppuwrite(ppufile);
  1364. end;
  1365. function tglobalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
  1366. var
  1367. hsym : tsym;
  1368. begin
  1369. result:=false;
  1370. hsym:=tsym(FindWithHash(hashedid));
  1371. if assigned(hsym) then
  1372. begin
  1373. { Delphi (contrary to TP) you can have a symbol with the same name as the
  1374. unit, the unit can then not be accessed anymore using
  1375. <unit>.<id>, so we can hide the symbol }
  1376. if (m_delphi in current_settings.modeswitches) and
  1377. (hsym.typ=symconst.unitsym) then
  1378. HideSym(hsym)
  1379. else
  1380. DuplicateSym(hashedid,sym,hsym);
  1381. result:=true;
  1382. exit;
  1383. end;
  1384. end;
  1385. {****************************************************************************
  1386. TWITHSYMTABLE
  1387. ****************************************************************************}
  1388. constructor twithsymtable.create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
  1389. begin
  1390. inherited create('');
  1391. symtabletype:=withsymtable;
  1392. withrefnode:=refnode;
  1393. { Replace SymList with the passed symlist }
  1394. SymList.free;
  1395. SymList:=ASymList;
  1396. defowner:=aowner;
  1397. end;
  1398. destructor twithsymtable.destroy;
  1399. begin
  1400. withrefnode.free;
  1401. { Disable SymList because we don't Own it }
  1402. SymList:=nil;
  1403. inherited destroy;
  1404. end;
  1405. procedure twithsymtable.clear;
  1406. begin
  1407. { remove no entry from a withsymtable as it is only a pointer to the
  1408. recorddef or objectdef symtable }
  1409. end;
  1410. procedure twithsymtable.insertdef(def:TDefEntry);
  1411. begin
  1412. { Definitions can't be registered in the withsymtable
  1413. because the withsymtable is removed after the with block.
  1414. We can't easily solve it here because the next symtable in the
  1415. stack is not known. }
  1416. internalerror(200602046);
  1417. end;
  1418. {****************************************************************************
  1419. TSTT_ExceptionSymtable
  1420. ****************************************************************************}
  1421. constructor tstt_excepTSymtable.create;
  1422. begin
  1423. inherited create('');
  1424. symtabletype:=stt_excepTSymtable;
  1425. end;
  1426. {****************************************************************************
  1427. TMacroSymtable
  1428. ****************************************************************************}
  1429. constructor tmacrosymtable.create(exported: boolean);
  1430. begin
  1431. inherited create('');
  1432. if exported then
  1433. symtabletype:=exportedmacrosymtable
  1434. else
  1435. symtabletype:=localmacrosymtable;
  1436. symtablelevel:=main_program_level;
  1437. end;
  1438. {****************************************************************************
  1439. TEnumSymtable
  1440. ****************************************************************************}
  1441. procedure tenumsymtable.insert(sym: TSymEntry; checkdup: boolean);
  1442. var
  1443. value: longint;
  1444. def: tenumdef;
  1445. begin
  1446. // defowner = nil only when we are loading from ppu
  1447. if defowner<>nil then
  1448. begin
  1449. { First entry? Then we need to set the minval }
  1450. value:=tenumsym(sym).value;
  1451. def:=tenumdef(defowner);
  1452. if SymList.count=0 then
  1453. begin
  1454. if value>0 then
  1455. def.has_jumps:=true;
  1456. def.setmin(value);
  1457. def.setmax(value);
  1458. end
  1459. else
  1460. begin
  1461. { check for jumps }
  1462. if value>def.max+1 then
  1463. def.has_jumps:=true;
  1464. { update low and high }
  1465. if def.min>value then
  1466. def.setmin(value);
  1467. if def.max<value then
  1468. def.setmax(value);
  1469. end;
  1470. end;
  1471. inherited insert(sym, checkdup);
  1472. end;
  1473. constructor tenumsymtable.create(adefowner: tdef);
  1474. begin
  1475. inherited Create('');
  1476. symtabletype:=enumsymtable;
  1477. defowner:=adefowner;
  1478. end;
  1479. {****************************************************************************
  1480. TArraySymtable
  1481. ****************************************************************************}
  1482. procedure tarraysymtable.insertdef(def: TDefEntry);
  1483. begin
  1484. { Enums must also be available outside the record scope,
  1485. insert in the owner of this symtable }
  1486. if def.typ=enumdef then
  1487. defowner.owner.insertdef(def)
  1488. else
  1489. inherited insertdef(def);
  1490. end;
  1491. constructor tarraysymtable.create(adefowner: tdef);
  1492. begin
  1493. inherited Create('');
  1494. symtabletype:=arraysymtable;
  1495. defowner:=adefowner;
  1496. end;
  1497. {*****************************************************************************
  1498. Helper Routines
  1499. *****************************************************************************}
  1500. function FullTypeName(def,otherdef:tdef):string;
  1501. var
  1502. s1,s2 : string;
  1503. begin
  1504. if def.typ in [objectdef,recorddef] then
  1505. s1:=tabstractrecorddef(def).RttiName
  1506. else
  1507. s1:=def.typename;
  1508. { When the names are the same try to include the unit name }
  1509. if assigned(otherdef) and
  1510. (def.owner.symtabletype in [globalsymtable,staticsymtable]) then
  1511. begin
  1512. s2:=otherdef.typename;
  1513. if upper(s1)=upper(s2) then
  1514. s1:=def.owner.realname^+'.'+s1;
  1515. end;
  1516. FullTypeName:=s1;
  1517. end;
  1518. function generate_nested_name(symtable:tsymtable;delimiter:string):string;
  1519. begin
  1520. result:='';
  1521. while assigned(symtable) and (symtable.symtabletype in [ObjectSymtable,recordsymtable]) do
  1522. begin
  1523. if (result='') then
  1524. result:=symtable.name^
  1525. else
  1526. result:=symtable.name^+delimiter+result;
  1527. symtable:=symtable.defowner.owner;
  1528. end;
  1529. end;
  1530. procedure incompatibletypes(def1,def2:tdef);
  1531. begin
  1532. { When there is an errordef there is already an error message show }
  1533. if (def2.typ=errordef) or
  1534. (def1.typ=errordef) then
  1535. exit;
  1536. CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
  1537. end;
  1538. procedure hidesym(sym:TSymEntry);
  1539. begin
  1540. sym.realname:='$hidden'+sym.realname;
  1541. tsym(sym).visibility:=vis_hidden;
  1542. end;
  1543. procedure duplicatesym(var hashedid:THashedIDString;dupsym,origsym:TSymEntry);
  1544. var
  1545. st : TSymtable;
  1546. begin
  1547. Message1(sym_e_duplicate_id,tsym(origsym).realname);
  1548. { Write hint where the original symbol was found }
  1549. st:=finduniTSymtable(origsym.owner);
  1550. with tsym(origsym).fileinfo do
  1551. begin
  1552. if assigned(st) and
  1553. (st.symtabletype=globalsymtable) and
  1554. st.iscurrentunit then
  1555. Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line))
  1556. else if assigned(st.name) then
  1557. Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line));
  1558. end;
  1559. { Rename duplicate sym to an unreachable name, but it can be
  1560. inserted in the symtable without errors }
  1561. inc(dupnr);
  1562. hashedid.id:='dup'+tostr(dupnr)+hashedid.id;
  1563. if assigned(dupsym) then
  1564. include(tsym(dupsym).symoptions,sp_implicitrename);
  1565. end;
  1566. {*****************************************************************************
  1567. Search
  1568. *****************************************************************************}
  1569. procedure addsymref(sym:tsym);
  1570. begin
  1571. { symbol uses count }
  1572. sym.IncRefCount;
  1573. { unit uses count }
  1574. if assigned(current_module) and
  1575. (sym.owner.symtabletype=globalsymtable) then
  1576. begin
  1577. if tglobalsymtable(sym.owner).moduleid>=current_module.unitmapsize then
  1578. internalerror(200501152);
  1579. inc(current_module.unitmap[tglobalsymtable(sym.owner).moduleid].refs);
  1580. end;
  1581. end;
  1582. function is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean;
  1583. begin
  1584. result:=childdef=ownerdef;
  1585. if not result and (childdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  1586. result:=is_owned_by(tabstractrecorddef(childdef.owner.defowner),ownerdef);
  1587. end;
  1588. function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
  1589. var
  1590. symownerdef : tabstractrecorddef;
  1591. begin
  1592. result:=false;
  1593. { Get objdectdef owner of the symtable for the is_related checks }
  1594. if not assigned(symst) or
  1595. not (symst.symtabletype in [objectsymtable,recordsymtable]) then
  1596. internalerror(200810285);
  1597. symownerdef:=tabstractrecorddef(symst.defowner);
  1598. case symvisibility of
  1599. vis_private :
  1600. begin
  1601. { private symbols are allowed when we are in the same
  1602. module as they are defined }
  1603. result:=(
  1604. (symownerdef.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1605. (symownerdef.owner.iscurrentunit)
  1606. ) or
  1607. ( // the case of specialize inside the generic declaration
  1608. (symownerdef.owner.symtabletype = objectsymtable) and
  1609. (
  1610. assigned(current_structdef) and
  1611. (
  1612. (current_structdef=symownerdef) or
  1613. (current_structdef.owner.iscurrentunit)
  1614. )
  1615. ) or
  1616. (
  1617. not assigned(current_structdef) and
  1618. (symownerdef.owner.iscurrentunit)
  1619. )
  1620. );
  1621. end;
  1622. vis_strictprivate :
  1623. begin
  1624. result:=assigned(current_structdef) and
  1625. is_owned_by(current_structdef,symownerdef);
  1626. end;
  1627. vis_strictprotected :
  1628. begin
  1629. result:=(
  1630. assigned(current_structdef) and
  1631. (current_structdef.is_related(symownerdef) or
  1632. is_owned_by(current_structdef,symownerdef))
  1633. ) or
  1634. (
  1635. { helpers can access strict protected symbols }
  1636. is_objectpascal_helper(contextobjdef) and
  1637. tobjectdef(contextobjdef).extendeddef.is_related(symownerdef)
  1638. );
  1639. end;
  1640. vis_protected :
  1641. begin
  1642. { protected symbols are visible in the module that defines them and
  1643. also visible to related objects. The related object must be defined
  1644. in the current module }
  1645. result:=(
  1646. (
  1647. (symownerdef.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1648. (symownerdef.owner.iscurrentunit)
  1649. ) or
  1650. (
  1651. assigned(contextobjdef) and
  1652. (contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable]) and
  1653. (contextobjdef.owner.iscurrentunit) and
  1654. contextobjdef.is_related(symownerdef)
  1655. ) or
  1656. ( // the case of specialize inside the generic declaration
  1657. (symownerdef.owner.symtabletype = objectsymtable) and
  1658. (
  1659. assigned(current_structdef) and
  1660. (
  1661. (current_structdef=symownerdef) or
  1662. (current_structdef.owner.iscurrentunit)
  1663. )
  1664. ) or
  1665. (
  1666. not assigned(current_structdef) and
  1667. (symownerdef.owner.iscurrentunit)
  1668. ) or
  1669. (
  1670. { helpers can access protected symbols }
  1671. is_objectpascal_helper(contextobjdef) and
  1672. tobjectdef(contextobjdef).extendeddef.is_related(symownerdef)
  1673. )
  1674. )
  1675. );
  1676. end;
  1677. vis_public,
  1678. vis_published :
  1679. result:=true;
  1680. end;
  1681. end;
  1682. function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
  1683. begin
  1684. result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef);
  1685. end;
  1686. function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
  1687. var
  1688. i : longint;
  1689. pd : tprocdef;
  1690. begin
  1691. if sym.typ=procsym then
  1692. begin
  1693. { A procsym is visible, when there is at least one of the procdefs visible }
  1694. result:=false;
  1695. for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
  1696. begin
  1697. pd:=tprocdef(tprocsym(sym).ProcdefList[i]);
  1698. if (pd.owner=sym.owner) and
  1699. is_visible_for_object(pd,contextobjdef) then
  1700. begin
  1701. result:=true;
  1702. exit;
  1703. end;
  1704. end;
  1705. end
  1706. else
  1707. result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef);
  1708. end;
  1709. function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  1710. var
  1711. hashedid : THashedIDString;
  1712. contextstructdef : tabstractrecorddef;
  1713. stackitem : psymtablestackitem;
  1714. begin
  1715. result:=false;
  1716. hashedid.id:=s;
  1717. stackitem:=symtablestack.stack;
  1718. while assigned(stackitem) do
  1719. begin
  1720. srsymtable:=stackitem^.symtable;
  1721. if (srsymtable.symtabletype=objectsymtable) then
  1722. begin
  1723. if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,true) then
  1724. begin
  1725. result:=true;
  1726. exit;
  1727. end;
  1728. end
  1729. else
  1730. begin
  1731. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  1732. if assigned(srsym) then
  1733. begin
  1734. { use the class from withsymtable only when it is
  1735. defined in this unit }
  1736. if (srsymtable.symtabletype=withsymtable) and
  1737. assigned(srsymtable.defowner) and
  1738. (srsymtable.defowner.typ in [recorddef,objectdef]) and
  1739. (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1740. (srsymtable.defowner.owner.iscurrentunit) then
  1741. contextstructdef:=tabstractrecorddef(srsymtable.defowner)
  1742. else
  1743. contextstructdef:=current_structdef;
  1744. if not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
  1745. is_visible_for_object(srsym,contextstructdef) then
  1746. begin
  1747. { we need to know if a procedure references symbols
  1748. in the static symtable, because then it can't be
  1749. inlined from outside this unit }
  1750. if assigned(current_procinfo) and
  1751. (srsym.owner.symtabletype=staticsymtable) then
  1752. include(current_procinfo.flags,pi_uses_static_symtable);
  1753. addsymref(srsym);
  1754. result:=true;
  1755. exit;
  1756. end;
  1757. end;
  1758. end;
  1759. stackitem:=stackitem^.next;
  1760. end;
  1761. srsym:=nil;
  1762. srsymtable:=nil;
  1763. end;
  1764. function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  1765. var
  1766. hashedid : THashedIDString;
  1767. stackitem : psymtablestackitem;
  1768. classh : tobjectdef;
  1769. begin
  1770. result:=false;
  1771. hashedid.id:=s;
  1772. stackitem:=symtablestack.stack;
  1773. while assigned(stackitem) do
  1774. begin
  1775. {
  1776. It is not possible to have type symbols in:
  1777. parameters
  1778. Exception are classes, objects, records, generic definitions and specializations
  1779. that have the parameterized types inserted in the symtable.
  1780. }
  1781. srsymtable:=stackitem^.symtable;
  1782. if (srsymtable.symtabletype=ObjectSymtable) then
  1783. begin
  1784. classh:=tobjectdef(srsymtable.defowner);
  1785. while assigned(classh) do
  1786. begin
  1787. srsymtable:=classh.symtable;
  1788. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  1789. if assigned(srsym) and
  1790. not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
  1791. is_visible_for_object(srsym,current_structdef) then
  1792. begin
  1793. addsymref(srsym);
  1794. result:=true;
  1795. exit;
  1796. end;
  1797. classh:=classh.childof;
  1798. end;
  1799. end
  1800. else
  1801. begin
  1802. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  1803. if assigned(srsym) and
  1804. not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
  1805. (not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,current_structdef)) then
  1806. begin
  1807. { we need to know if a procedure references symbols
  1808. in the static symtable, because then it can't be
  1809. inlined from outside this unit }
  1810. if assigned(current_procinfo) and
  1811. (srsym.owner.symtabletype=staticsymtable) then
  1812. include(current_procinfo.flags,pi_uses_static_symtable);
  1813. addsymref(srsym);
  1814. result:=true;
  1815. exit;
  1816. end;
  1817. end;
  1818. stackitem:=stackitem^.next;
  1819. end;
  1820. result:=false;
  1821. srsym:=nil;
  1822. srsymtable:=nil;
  1823. end;
  1824. function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  1825. var
  1826. pmod : tmodule;
  1827. begin
  1828. pmod:=tmodule(pm);
  1829. result:=false;
  1830. if assigned(pmod.globalsymtable) then
  1831. begin
  1832. srsym:=tsym(pmod.globalsymtable.Find(s));
  1833. if assigned(srsym) then
  1834. begin
  1835. srsymtable:=pmod.globalsymtable;
  1836. addsymref(srsym);
  1837. result:=true;
  1838. exit;
  1839. end;
  1840. end;
  1841. { If the module is the current unit we also need
  1842. to search the local symtable }
  1843. if (pmod=current_module) and
  1844. assigned(pmod.localsymtable) then
  1845. begin
  1846. srsym:=tsym(pmod.localsymtable.Find(s));
  1847. if assigned(srsym) then
  1848. begin
  1849. srsymtable:=pmod.localsymtable;
  1850. addsymref(srsym);
  1851. result:=true;
  1852. exit;
  1853. end;
  1854. end;
  1855. srsym:=nil;
  1856. srsymtable:=nil;
  1857. end;
  1858. function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
  1859. var
  1860. stackitem : psymtablestackitem;
  1861. begin
  1862. result:=false;
  1863. stackitem:=symtablestack.stack;
  1864. while assigned(stackitem) do
  1865. begin
  1866. srsymtable:=stackitem^.symtable;
  1867. if (srsymtable.symtabletype=globalsymtable) and
  1868. (srsymtable.name^=unitname) then
  1869. begin
  1870. srsym:=tsym(srsymtable.find(symname));
  1871. if not assigned(srsym) then
  1872. break;
  1873. result:=true;
  1874. exit;
  1875. end;
  1876. stackitem:=stackitem^.next;
  1877. end;
  1878. { If the module is the current unit we also need
  1879. to search the local symtable }
  1880. if (current_module.globalsymtable=srsymtable) and
  1881. assigned(current_module.localsymtable) then
  1882. begin
  1883. srsymtable:=current_module.localsymtable;
  1884. srsym:=tsym(srsymtable.find(symname));
  1885. if assigned(srsym) then
  1886. begin
  1887. result:=true;
  1888. exit;
  1889. end;
  1890. end;
  1891. end;
  1892. function find_real_objcclass_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
  1893. var
  1894. hashedid : THashedIDString;
  1895. stackitem : psymtablestackitem;
  1896. srsymtable : tsymtable;
  1897. srsym : tsym;
  1898. begin
  1899. { not a formal definition -> return it }
  1900. if not(oo_is_formal in pd.objectoptions) then
  1901. begin
  1902. result:=pd;
  1903. exit;
  1904. end;
  1905. hashedid.id:=pd.typesym.name;
  1906. stackitem:=symtablestack.stack;
  1907. while assigned(stackitem) do
  1908. begin
  1909. srsymtable:=stackitem^.symtable;
  1910. { ObjC classes can't appear in generics or as nested class
  1911. definitions }
  1912. if not(srsymtable.symtabletype in [recordsymtable,ObjectSymtable,parasymtable]) then
  1913. begin
  1914. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  1915. if assigned(srsym) and
  1916. (srsym.typ=typesym) and
  1917. is_objcclass(ttypesym(srsym).typedef) and
  1918. not(oo_is_formal in tobjectdef(ttypesym(srsym).typedef).objectoptions) then
  1919. begin
  1920. { the external name for the formal and the real definition must match }
  1921. if tobjectdef(ttypesym(srsym).typedef).objextname^<>pd.objextname^ then
  1922. begin
  1923. Message2(sym_e_external_class_name_mismatch1,pd.objextname^,pd.typename);
  1924. MessagePos1(srsym.fileinfo,sym_e_external_class_name_mismatch2,tobjectdef(ttypesym(srsym).typedef).objextname^);
  1925. end;
  1926. result:=tobjectdef(ttypesym(srsym).typedef);
  1927. if assigned(current_procinfo) and
  1928. (srsym.owner.symtabletype=staticsymtable) then
  1929. include(current_procinfo.flags,pi_uses_static_symtable);
  1930. addsymref(srsym);
  1931. exit;
  1932. end;
  1933. end;
  1934. stackitem:=stackitem^.next;
  1935. end;
  1936. { nothing found: optionally give an error and return the original
  1937. (empty) one }
  1938. if erroronfailure then
  1939. Message1(sym_e_objc_formal_class_not_resolved,pd.objrealname^);
  1940. result:=pd;
  1941. end;
  1942. function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
  1943. var
  1944. hashedid : THashedIDString;
  1945. orgclass : tobjectdef;
  1946. i : longint;
  1947. begin
  1948. orgclass:=classh;
  1949. { in case this is a formal objcclass, first find the real definition }
  1950. if assigned(classh) then
  1951. begin
  1952. if (oo_is_formal in classh.objectoptions) then
  1953. classh:=find_real_objcclass_definition(classh,true);
  1954. { The contextclassh is used for visibility. The classh must be equal to
  1955. or be a parent of contextclassh. E.g. for inherited searches the classh is the
  1956. parent or a class helper. }
  1957. if not (contextclassh.is_related(classh) or
  1958. (assigned(contextclassh.extendeddef) and
  1959. (contextclassh.extendeddef.typ=objectdef) and
  1960. contextclassh.extendeddef.is_related(classh))) then
  1961. internalerror(200811161);
  1962. end;
  1963. result:=false;
  1964. hashedid.id:=s;
  1965. { an Objective-C protocol can inherit from multiple other protocols
  1966. -> uses ImplementedInterfaces instead }
  1967. if is_objcprotocol(classh) then
  1968. begin
  1969. srsymtable:=classh.symtable;
  1970. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  1971. if assigned(srsym) and
  1972. is_visible_for_object(srsym,contextclassh) then
  1973. begin
  1974. addsymref(srsym);
  1975. result:=true;
  1976. exit;
  1977. end;
  1978. for i:=0 to classh.ImplementedInterfaces.count-1 do
  1979. begin
  1980. if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,false) then
  1981. begin
  1982. result:=true;
  1983. exit;
  1984. end;
  1985. end;
  1986. end
  1987. else
  1988. if is_objectpascal_helper(classh) then
  1989. begin
  1990. { helpers have their own obscure search logic... }
  1991. result:=searchsym_in_helper(classh,contextclassh,s,srsym,srsymtable,false);
  1992. if result then
  1993. exit;
  1994. end
  1995. else
  1996. begin
  1997. while assigned(classh) do
  1998. begin
  1999. { search for a class helper method first if this is an Object
  2000. Pascal class }
  2001. if is_class(classh) and searchhelper then
  2002. begin
  2003. result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable);
  2004. if result then
  2005. { if the procsym is overloaded we need to use the
  2006. "original" symbol; the helper symbol will be found when
  2007. searching for overloads }
  2008. if (srsym.typ<>procsym) or
  2009. not (sp_has_overloaded in tprocsym(srsym).symoptions) then
  2010. exit;
  2011. end;
  2012. srsymtable:=classh.symtable;
  2013. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2014. if assigned(srsym) and
  2015. is_visible_for_object(srsym,contextclassh) then
  2016. begin
  2017. addsymref(srsym);
  2018. result:=true;
  2019. exit;
  2020. end;
  2021. classh:=classh.childof;
  2022. end;
  2023. end;
  2024. if is_objcclass(orgclass) then
  2025. result:=search_objc_helper(orgclass,s,srsym,srsymtable)
  2026. else
  2027. begin
  2028. srsym:=nil;
  2029. srsymtable:=nil;
  2030. end;
  2031. end;
  2032. function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2033. var
  2034. hashedid : THashedIDString;
  2035. begin
  2036. result:=false;
  2037. hashedid.id:=s;
  2038. { search for a record helper method first }
  2039. result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable);
  2040. if result then
  2041. { if the procsym is overloaded we need to use the
  2042. "original" symbol; the helper symbol will be found when
  2043. searching for overloads }
  2044. if (srsym.typ<>procsym) or
  2045. not (sp_has_overloaded in tprocsym(srsym).symoptions) then
  2046. exit;
  2047. srsymtable:=recordh.symtable;
  2048. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2049. if assigned(srsym) and is_visible_for_object(srsym,recordh) then
  2050. begin
  2051. addsymref(srsym);
  2052. result:=true;
  2053. exit;
  2054. end;
  2055. srsym:=nil;
  2056. srsymtable:=nil;
  2057. end;
  2058. function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2059. var
  2060. def : tdef;
  2061. i : longint;
  2062. begin
  2063. { in case this is a formal objcclass, first find the real definition }
  2064. if assigned(classh) and
  2065. (oo_is_formal in classh.objectoptions) then
  2066. classh:=find_real_objcclass_definition(classh,true);
  2067. result:=false;
  2068. def:=nil;
  2069. while assigned(classh) do
  2070. begin
  2071. for i:=0 to classh.symtable.DefList.Count-1 do
  2072. begin
  2073. def:=tstoreddef(classh.symtable.DefList[i]);
  2074. { Find also all hidden private methods to
  2075. be compatible with delphi, see tw6203 (PFV) }
  2076. if (def.typ=procdef) and
  2077. (po_msgint in tprocdef(def).procoptions) and
  2078. (tprocdef(def).messageinf.i=msgid) then
  2079. begin
  2080. srdef:=def;
  2081. srsym:=tprocdef(def).procsym;
  2082. srsymtable:=classh.symtable;
  2083. addsymref(srsym);
  2084. result:=true;
  2085. exit;
  2086. end;
  2087. end;
  2088. classh:=classh.childof;
  2089. end;
  2090. srdef:=nil;
  2091. srsym:=nil;
  2092. srsymtable:=nil;
  2093. end;
  2094. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
  2095. var
  2096. def : tdef;
  2097. i : longint;
  2098. begin
  2099. { in case this is a formal objcclass, first find the real definition }
  2100. if assigned(classh) and
  2101. (oo_is_formal in classh.objectoptions) then
  2102. classh:=find_real_objcclass_definition(classh,true);
  2103. result:=false;
  2104. def:=nil;
  2105. while assigned(classh) do
  2106. begin
  2107. for i:=0 to classh.symtable.DefList.Count-1 do
  2108. begin
  2109. def:=tstoreddef(classh.symtable.DefList[i]);
  2110. { Find also all hidden private methods to
  2111. be compatible with delphi, see tw6203 (PFV) }
  2112. if (def.typ=procdef) and
  2113. (po_msgstr in tprocdef(def).procoptions) and
  2114. (tprocdef(def).messageinf.str^=s) then
  2115. begin
  2116. srsym:=tprocdef(def).procsym;
  2117. srsymtable:=classh.symtable;
  2118. addsymref(srsym);
  2119. result:=true;
  2120. exit;
  2121. end;
  2122. end;
  2123. classh:=classh.childof;
  2124. end;
  2125. srsym:=nil;
  2126. srsymtable:=nil;
  2127. end;
  2128. function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;aHasInherited:boolean):boolean;
  2129. var
  2130. hashedid : THashedIDString;
  2131. parentclassh : tobjectdef;
  2132. begin
  2133. result:=false;
  2134. if not is_objectpascal_helper(classh) then
  2135. Internalerror(2011030101);
  2136. hashedid.id:=s;
  2137. { in a helper things are a bit more complex:
  2138. 1. search the symbol in the helper (if not "inherited")
  2139. 2. search the symbol in the extended type
  2140. 3. search the symbol in the parent helpers
  2141. 4. only classes: search the symbol in the parents of the extended type
  2142. }
  2143. if not aHasInherited then
  2144. begin
  2145. { search in the helper itself }
  2146. srsymtable:=classh.symtable;
  2147. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2148. if assigned(srsym) and
  2149. is_visible_for_object(srsym,contextclassh) then
  2150. begin
  2151. addsymref(srsym);
  2152. result:=true;
  2153. exit;
  2154. end;
  2155. end;
  2156. { now search in the extended type itself }
  2157. srsymtable:=classh.extendeddef.symtable;
  2158. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2159. if assigned(srsym) and
  2160. is_visible_for_object(srsym,contextclassh) then
  2161. begin
  2162. addsymref(srsym);
  2163. result:=true;
  2164. exit;
  2165. end;
  2166. { now search in the parent helpers }
  2167. parentclassh:=classh.childof;
  2168. while assigned(parentclassh) do
  2169. begin
  2170. srsymtable:=parentclassh.symtable;
  2171. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2172. if assigned(srsym) and
  2173. is_visible_for_object(srsym,contextclassh) then
  2174. begin
  2175. addsymref(srsym);
  2176. result:=true;
  2177. exit;
  2178. end;
  2179. parentclassh:=parentclassh.childof;
  2180. end;
  2181. if is_class(classh.extendeddef) then
  2182. { now search in the parents of the extended class (with helpers!) }
  2183. result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,true);
  2184. { addsymref is already called by searchsym_in_class }
  2185. end;
  2186. function search_specific_assignment_operator(assignment_type:ttoken;from_def,to_def:Tdef):Tprocdef;
  2187. var
  2188. sym : Tprocsym;
  2189. hashedid : THashedIDString;
  2190. curreq,
  2191. besteq : tequaltype;
  2192. currpd,
  2193. bestpd : tprocdef;
  2194. stackitem : psymtablestackitem;
  2195. begin
  2196. hashedid.id:=overloaded_names[assignment_type];
  2197. besteq:=te_incompatible;
  2198. bestpd:=nil;
  2199. stackitem:=symtablestack.stack;
  2200. while assigned(stackitem) do
  2201. begin
  2202. sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
  2203. if sym<>nil then
  2204. begin
  2205. if sym.typ<>procsym then
  2206. internalerror(200402031);
  2207. { if the source type is an alias then this is only the second choice,
  2208. if you mess with this code, check tw4093 }
  2209. currpd:=sym.find_procdef_assignment_operator(from_def,to_def,curreq);
  2210. if curreq>besteq then
  2211. begin
  2212. besteq:=curreq;
  2213. bestpd:=currpd;
  2214. if (besteq=te_exact) then
  2215. break;
  2216. end;
  2217. end;
  2218. stackitem:=stackitem^.next;
  2219. end;
  2220. result:=bestpd;
  2221. end;
  2222. function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
  2223. begin
  2224. { search record/object symtable first for a suitable operator }
  2225. if from_def.typ in [recorddef,objectdef] then
  2226. symtablestack.push(tabstractrecorddef(from_def).symtable);
  2227. if to_def.typ in [recorddef,objectdef] then
  2228. symtablestack.push(tabstractrecorddef(to_def).symtable);
  2229. { if type conversion is explicit then search first for explicit
  2230. operator overload and if not found then use implicit operator }
  2231. if explicit then
  2232. result:=search_specific_assignment_operator(_OP_EXPLICIT,from_def,to_def)
  2233. else
  2234. result:=nil;
  2235. if result=nil then
  2236. result:=search_specific_assignment_operator(_ASSIGNMENT,from_def,to_def);
  2237. { restore symtable stack }
  2238. if to_def.typ in [recorddef,objectdef] then
  2239. symtablestack.pop(tabstractrecorddef(to_def).symtable);
  2240. if from_def.typ in [recorddef,objectdef] then
  2241. symtablestack.pop(tabstractrecorddef(from_def).symtable);
  2242. end;
  2243. function search_enumerator_operator(from_def,to_def:Tdef): Tprocdef;
  2244. var
  2245. sym : Tprocsym;
  2246. hashedid : THashedIDString;
  2247. curreq,
  2248. besteq : tequaltype;
  2249. currpd,
  2250. bestpd : tprocdef;
  2251. stackitem : psymtablestackitem;
  2252. begin
  2253. hashedid.id:='enumerator';
  2254. besteq:=te_incompatible;
  2255. bestpd:=nil;
  2256. stackitem:=symtablestack.stack;
  2257. while assigned(stackitem) do
  2258. begin
  2259. sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
  2260. if sym<>nil then
  2261. begin
  2262. if sym.typ<>procsym then
  2263. internalerror(200910241);
  2264. { if the source type is an alias then this is only the second choice,
  2265. if you mess with this code, check tw4093 }
  2266. currpd:=sym.find_procdef_enumerator_operator(from_def,to_def,curreq);
  2267. if curreq>besteq then
  2268. begin
  2269. besteq:=curreq;
  2270. bestpd:=currpd;
  2271. if (besteq=te_exact) then
  2272. break;
  2273. end;
  2274. end;
  2275. stackitem:=stackitem^.next;
  2276. end;
  2277. result:=bestpd;
  2278. end;
  2279. function search_system_type(const s: TIDString): ttypesym;
  2280. var
  2281. sym : tsym;
  2282. begin
  2283. sym:=tsym(systemunit.Find(s));
  2284. if not assigned(sym) or
  2285. (sym.typ<>typesym) then
  2286. cgmessage1(cg_f_unknown_system_type,s);
  2287. result:=ttypesym(sym);
  2288. end;
  2289. function try_search_system_type(const s: TIDString): ttypesym;
  2290. var
  2291. sym : tsym;
  2292. begin
  2293. sym:=tsym(systemunit.Find(s));
  2294. if not assigned(sym) then
  2295. result:=nil
  2296. else
  2297. begin
  2298. if sym.typ<>typesym then
  2299. cgmessage1(cg_f_unknown_system_type,s);
  2300. result:=ttypesym(sym);
  2301. end;
  2302. end;
  2303. function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
  2304. var
  2305. srsymtable: tsymtable;
  2306. sym: tsym;
  2307. begin
  2308. if searchsym_in_named_module(unitname,typename,sym,srsymtable) and
  2309. (sym.typ=typesym) then
  2310. begin
  2311. result:=ttypesym(sym);
  2312. exit;
  2313. end
  2314. else
  2315. begin
  2316. if throwerror then
  2317. cgmessage2(cg_f_unknown_type_in_unit,typename,unitname);
  2318. result:=nil;
  2319. end;
  2320. end;
  2321. function search_last_objectpascal_helper(pd,contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
  2322. var
  2323. s: string;
  2324. list: TFPObjectList;
  2325. i: integer;
  2326. st: tsymtable;
  2327. begin
  2328. result:=false;
  2329. odef:=nil;
  2330. { when there are no helpers active currently then we don't need to do
  2331. anything }
  2332. if current_module.extendeddefs.count=0 then
  2333. exit;
  2334. { no helpers for anonymous types }
  2335. if not assigned(pd.objrealname) or (pd.objrealname^='') then
  2336. exit;
  2337. { if pd is defined inside a procedure we must not use make_mangledname
  2338. (as a helper may not be defined in a procedure this is no problem...)}
  2339. st:=pd.owner;
  2340. while st.symtabletype in [objectsymtable,recordsymtable] do
  2341. st:=st.defowner.owner;
  2342. if st.symtabletype=localsymtable then
  2343. exit;
  2344. { the mangled name is used as the key for tmodule.extendeddefs }
  2345. s:=make_mangledname('',pd.symtable,'');
  2346. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  2347. if assigned(list) and (list.count>0) then
  2348. begin
  2349. i:=list.count-1;
  2350. repeat
  2351. odef:=tobjectdef(list[list.count-1]);
  2352. result:=(odef.owner.symtabletype in [staticsymtable,globalsymtable]) or
  2353. is_visible_for_object(tobjectdef(list[i]).typesym,contextclassh);
  2354. dec(i);
  2355. until result or (i<0);
  2356. if not result then
  2357. { just to be sure that noone uses odef }
  2358. odef:=nil;
  2359. end;
  2360. end;
  2361. function search_objectpascal_helper(pd,contextclassh : tabstractrecorddef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  2362. var
  2363. hashedid : THashedIDString;
  2364. classh : tobjectdef;
  2365. i : integer;
  2366. pdef : tprocdef;
  2367. begin
  2368. result:=false;
  2369. { if there is no class helper for the class then there is no need to
  2370. search further }
  2371. if not search_last_objectpascal_helper(pd,contextclassh,classh) then
  2372. exit;
  2373. hashedid.id:=s;
  2374. repeat
  2375. srsymtable:=classh.symtable;
  2376. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2377. if srsym<>nil then
  2378. begin
  2379. if srsym.typ=propertysym then
  2380. begin
  2381. result:=true;
  2382. exit;
  2383. end;
  2384. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  2385. begin
  2386. pdef:=tprocdef(tprocsym(srsym).procdeflist[i]);
  2387. if not is_visible_for_object(pdef.owner,pdef.visibility,contextclassh) then
  2388. continue;
  2389. { we need to know if a procedure references symbols
  2390. in the static symtable, because then it can't be
  2391. inlined from outside this unit }
  2392. if assigned(current_procinfo) and
  2393. (srsym.owner.symtabletype=staticsymtable) then
  2394. include(current_procinfo.flags,pi_uses_static_symtable);
  2395. { the first found method wins }
  2396. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  2397. srsymtable:=srsym.owner;
  2398. addsymref(srsym);
  2399. result:=true;
  2400. exit;
  2401. end;
  2402. end;
  2403. { try the helper parent if available }
  2404. classh:=classh.childof;
  2405. until classh=nil;
  2406. srsym:=nil;
  2407. srsymtable:=nil;
  2408. end;
  2409. function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  2410. var
  2411. hashedid : THashedIDString;
  2412. stackitem : psymtablestackitem;
  2413. i : longint;
  2414. defowner : tobjectdef;
  2415. begin
  2416. hashedid.id:=class_helper_prefix+s;
  2417. stackitem:=symtablestack.stack;
  2418. while assigned(stackitem) do
  2419. begin
  2420. srsymtable:=stackitem^.symtable;
  2421. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2422. if assigned(srsym) then
  2423. begin
  2424. if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
  2425. not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
  2426. (srsym.typ<>procsym) then
  2427. internalerror(2009111505);
  2428. { check whether this procsym includes a helper for this particular class }
  2429. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  2430. begin
  2431. { does pd inherit from (or is the same as) the class
  2432. that this method's category extended?
  2433. Warning: this list contains both category and objcclass methods
  2434. (for id.randommethod), so only check category methods here
  2435. }
  2436. defowner:=tobjectdef(tprocdef(tprocsym(srsym).procdeflist[i]).owner.defowner);
  2437. if (oo_is_classhelper in defowner.objectoptions) and
  2438. pd.is_related(defowner.childof) then
  2439. begin
  2440. { we need to know if a procedure references symbols
  2441. in the static symtable, because then it can't be
  2442. inlined from outside this unit }
  2443. if assigned(current_procinfo) and
  2444. (srsym.owner.symtabletype=staticsymtable) then
  2445. include(current_procinfo.flags,pi_uses_static_symtable);
  2446. { no need to keep looking. There might be other
  2447. categories that extend this, a parent or child
  2448. class with a method with the same name (either
  2449. overriding this one, or overridden by this one),
  2450. but that doesn't matter as far as the basic
  2451. procsym is concerned.
  2452. }
  2453. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  2454. srsymtable:=srsym.owner;
  2455. addsymref(srsym);
  2456. result:=true;
  2457. exit;
  2458. end;
  2459. end;
  2460. end;
  2461. stackitem:=stackitem^.next;
  2462. end;
  2463. srsym:=nil;
  2464. srsymtable:=nil;
  2465. result:=false;
  2466. end;
  2467. function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
  2468. var
  2469. hashedid : THashedIDString;
  2470. stackitem : psymtablestackitem;
  2471. i : longint;
  2472. begin
  2473. hashedid.id:=class_helper_prefix+s;
  2474. stackitem:=symtablestack.stack;
  2475. while assigned(stackitem) do
  2476. begin
  2477. srsymtable:=stackitem^.symtable;
  2478. srsym:=tsym(srsymtable.FindWithHash(hashedid));
  2479. if assigned(srsym) then
  2480. begin
  2481. if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
  2482. not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
  2483. (srsym.typ<>procsym) then
  2484. internalerror(2009112005);
  2485. { check whether this procsym includes a helper for this particular class }
  2486. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  2487. begin
  2488. { we need to know if a procedure references symbols
  2489. in the static symtable, because then it can't be
  2490. inlined from outside this unit }
  2491. if assigned(current_procinfo) and
  2492. (srsym.owner.symtabletype=staticsymtable) then
  2493. include(current_procinfo.flags,pi_uses_static_symtable);
  2494. { no need to keep looking. There might be other
  2495. methods with the same name, but that doesn't matter
  2496. as far as the basic procsym is concerned.
  2497. }
  2498. srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
  2499. { We need the symtable in which the classhelper-like sym
  2500. is located, not the objectdef. The reason is that the
  2501. callnode will climb the symtablestack until it encounters
  2502. this symtable to start looking for overloads (and it won't
  2503. find the objectsymtable in which this method sym is
  2504. located
  2505. srsymtable:=srsym.owner;
  2506. }
  2507. addsymref(srsym);
  2508. result:=true;
  2509. exit;
  2510. end;
  2511. end;
  2512. stackitem:=stackitem^.next;
  2513. end;
  2514. srsym:=nil;
  2515. srsymtable:=nil;
  2516. result:=false;
  2517. end;
  2518. function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
  2519. { searches n in symtable of pd and all anchestors }
  2520. var
  2521. hashedid : THashedIDString;
  2522. srsym : tsym;
  2523. orgpd : tabstractrecorddef;
  2524. srsymtable : tsymtable;
  2525. begin
  2526. { in case this is a formal objcclass, first find the real definition }
  2527. if (oo_is_formal in pd.objectoptions) then
  2528. pd:=find_real_objcclass_definition(tobjectdef(pd),true);
  2529. if search_objectpascal_helper(pd, pd, s, result, srsymtable) then
  2530. exit;
  2531. hashedid.id:=s;
  2532. orgpd:=pd;
  2533. while assigned(pd) do
  2534. begin
  2535. srsym:=tsym(pd.symtable.FindWithHash(hashedid));
  2536. if assigned(srsym) then
  2537. begin
  2538. search_struct_member:=srsym;
  2539. exit;
  2540. end;
  2541. if pd.typ=objectdef then
  2542. pd:=tobjectdef(pd).childof
  2543. else
  2544. pd:=nil;
  2545. end;
  2546. { not found, now look for class helpers }
  2547. if is_objcclass(pd) then
  2548. search_objc_helper(tobjectdef(orgpd),s,result,srsymtable)
  2549. else
  2550. result:=nil;
  2551. end;
  2552. function search_macro(const s : string):tsym;
  2553. var
  2554. stackitem : psymtablestackitem;
  2555. hashedid : THashedIDString;
  2556. srsym : tsym;
  2557. begin
  2558. hashedid.id:=s;
  2559. { First search the localmacrosymtable before searching the
  2560. global macrosymtables from the units }
  2561. if assigned(current_module) then
  2562. begin
  2563. srsym:=tsym(current_module.localmacrosymtable.FindWithHash(hashedid));
  2564. if assigned(srsym) then
  2565. begin
  2566. result:= srsym;
  2567. exit;
  2568. end;
  2569. end;
  2570. stackitem:=macrosymtablestack.stack;
  2571. while assigned(stackitem) do
  2572. begin
  2573. srsym:=tsym(stackitem^.symtable.FindWithHash(hashedid));
  2574. if assigned(srsym) then
  2575. begin
  2576. result:= srsym;
  2577. exit;
  2578. end;
  2579. stackitem:=stackitem^.next;
  2580. end;
  2581. result:= nil;
  2582. end;
  2583. function defined_macro(const s : string):boolean;
  2584. var
  2585. mac: tmacro;
  2586. begin
  2587. mac:=tmacro(search_macro(s));
  2588. if assigned(mac) then
  2589. begin
  2590. mac.is_used:=true;
  2591. defined_macro:=mac.defined;
  2592. end
  2593. else
  2594. defined_macro:=false;
  2595. end;
  2596. {****************************************************************************
  2597. Object Helpers
  2598. ****************************************************************************}
  2599. function search_default_property(pd : tabstractrecorddef) : tpropertysym;
  2600. { returns the default property of a class, searches also anchestors }
  2601. var
  2602. _defaultprop : tpropertysym;
  2603. helperpd : tobjectdef;
  2604. begin
  2605. _defaultprop:=nil;
  2606. { first search in helper's hierarchy }
  2607. if search_last_objectpascal_helper(pd,nil,helperpd) then
  2608. while assigned(helperpd) do
  2609. begin
  2610. helperpd.symtable.SymList.ForEachCall(@tstoredsymtable(helperpd.symtable).testfordefaultproperty,@_defaultprop);
  2611. if assigned(_defaultprop) then
  2612. break;
  2613. helperpd:=helperpd.childof;
  2614. end;
  2615. if assigned(_defaultprop) then
  2616. begin
  2617. search_default_property:=_defaultprop;
  2618. exit;
  2619. end;
  2620. { now search in the type's hierarchy itself }
  2621. while assigned(pd) do
  2622. begin
  2623. pd.symtable.SymList.ForEachCall(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop);
  2624. if assigned(_defaultprop) then
  2625. break;
  2626. if (pd.typ=objectdef) then
  2627. pd:=tobjectdef(pd).childof
  2628. else
  2629. break;
  2630. end;
  2631. search_default_property:=_defaultprop;
  2632. end;
  2633. {****************************************************************************
  2634. Macro Helpers
  2635. ****************************************************************************}
  2636. procedure def_system_macro(const name : string);
  2637. var
  2638. mac : tmacro;
  2639. s: string;
  2640. begin
  2641. if name = '' then
  2642. internalerror(2004121202);
  2643. s:= upper(name);
  2644. mac:=tmacro(search_macro(s));
  2645. if not assigned(mac) then
  2646. begin
  2647. mac:=tmacro.create(s);
  2648. if assigned(current_module) then
  2649. current_module.localmacrosymtable.insert(mac)
  2650. else
  2651. initialmacrosymtable.insert(mac);
  2652. end;
  2653. Message1(parser_c_macro_defined,mac.name);
  2654. mac.defined:=true;
  2655. end;
  2656. procedure set_system_macro(const name, value : string);
  2657. var
  2658. mac : tmacro;
  2659. s: string;
  2660. begin
  2661. if name = '' then
  2662. internalerror(2004121203);
  2663. s:= upper(name);
  2664. mac:=tmacro(search_macro(s));
  2665. if not assigned(mac) then
  2666. begin
  2667. mac:=tmacro.create(s);
  2668. if assigned(current_module) then
  2669. current_module.localmacrosymtable.insert(mac)
  2670. else
  2671. initialmacrosymtable.insert(mac);
  2672. end
  2673. else
  2674. begin
  2675. mac.is_compiler_var:=false;
  2676. if assigned(mac.buftext) then
  2677. freemem(mac.buftext,mac.buflen);
  2678. end;
  2679. Message2(parser_c_macro_set_to,mac.name,value);
  2680. mac.buflen:=length(value);
  2681. getmem(mac.buftext,mac.buflen);
  2682. move(value[1],mac.buftext^,mac.buflen);
  2683. mac.defined:=true;
  2684. end;
  2685. procedure set_system_compvar(const name, value : string);
  2686. var
  2687. mac : tmacro;
  2688. s: string;
  2689. begin
  2690. if name = '' then
  2691. internalerror(2004121204);
  2692. s:= upper(name);
  2693. mac:=tmacro(search_macro(s));
  2694. if not assigned(mac) then
  2695. begin
  2696. mac:=tmacro.create(s);
  2697. mac.is_compiler_var:=true;
  2698. if assigned(current_module) then
  2699. current_module.localmacrosymtable.insert(mac)
  2700. else
  2701. initialmacrosymtable.insert(mac);
  2702. end
  2703. else
  2704. begin
  2705. mac.is_compiler_var:=true;
  2706. if assigned(mac.buftext) then
  2707. freemem(mac.buftext,mac.buflen);
  2708. end;
  2709. Message2(parser_c_macro_set_to,mac.name,value);
  2710. mac.buflen:=length(value);
  2711. getmem(mac.buftext,mac.buflen);
  2712. move(value[1],mac.buftext^,mac.buflen);
  2713. mac.defined:=true;
  2714. end;
  2715. procedure undef_system_macro(const name : string);
  2716. var
  2717. mac : tmacro;
  2718. s: string;
  2719. begin
  2720. if name = '' then
  2721. internalerror(2004121205);
  2722. s:= upper(name);
  2723. mac:=tmacro(search_macro(s));
  2724. if not assigned(mac) then
  2725. {If not found, then it's already undefined.}
  2726. else
  2727. begin
  2728. Message1(parser_c_macro_undefined,mac.name);
  2729. mac.defined:=false;
  2730. mac.is_compiler_var:=false;
  2731. { delete old definition }
  2732. if assigned(mac.buftext) then
  2733. begin
  2734. freemem(mac.buftext,mac.buflen);
  2735. mac.buftext:=nil;
  2736. end;
  2737. end;
  2738. end;
  2739. {$ifdef UNITALIASES}
  2740. {****************************************************************************
  2741. TUNIT_ALIAS
  2742. ****************************************************************************}
  2743. constructor tunit_alias.create(const n:string);
  2744. var
  2745. i : longint;
  2746. begin
  2747. i:=pos('=',n);
  2748. if i=0 then
  2749. fail;
  2750. inherited createname(Copy(n,1,i-1));
  2751. newname:=stringdup(Copy(n,i+1,255));
  2752. end;
  2753. destructor tunit_alias.destroy;
  2754. begin
  2755. stringdispose(newname);
  2756. inherited destroy;
  2757. end;
  2758. procedure addunitalias(const n:string);
  2759. begin
  2760. unitaliases^.insert(tunit_alias,init(Upper(n))));
  2761. end;
  2762. function getunitalias(const n:string):string;
  2763. var
  2764. p : punit_alias;
  2765. begin
  2766. p:=punit_alias(unitaliases^.Find(Upper(n)));
  2767. if assigned(p) then
  2768. getunitalias:=punit_alias(p).newname^
  2769. else
  2770. getunitalias:=n;
  2771. end;
  2772. {$endif UNITALIASES}
  2773. {****************************************************************************
  2774. Init/Done Symtable
  2775. ****************************************************************************}
  2776. procedure InitSymtable;
  2777. begin
  2778. { Reset symbolstack }
  2779. symtablestack:=nil;
  2780. systemunit:=nil;
  2781. { create error syms and def }
  2782. generrorsym:=terrorsym.create;
  2783. generrordef:=terrordef.create;
  2784. { macros }
  2785. initialmacrosymtable:=tmacrosymtable.create(false);
  2786. macrosymtablestack:=TSymtablestack.create;
  2787. macrosymtablestack.push(initialmacrosymtable);
  2788. {$ifdef UNITALIASES}
  2789. { unit aliases }
  2790. unitaliases:=TFPHashObjectList.create;
  2791. {$endif}
  2792. { set some global vars to nil, might be important for the ide }
  2793. class_tobject:=nil;
  2794. interface_iunknown:=nil;
  2795. interface_idispatch:=nil;
  2796. rec_tguid:=nil;
  2797. dupnr:=0;
  2798. end;
  2799. procedure DoneSymtable;
  2800. begin
  2801. generrorsym.owner:=nil;
  2802. generrorsym.free;
  2803. generrordef.owner:=nil;
  2804. generrordef.free;
  2805. initialmacrosymtable.free;
  2806. macrosymtablestack.free;
  2807. {$ifdef UNITALIASES}
  2808. unitaliases.free;
  2809. {$endif}
  2810. end;
  2811. end.