symtable.pas 77 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  4. This unit handles the symbol tables
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit symtable;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. { common }
  23. cutils,cclasses,
  24. { global }
  25. cpuinfo,globtype,tokens,
  26. { symtable }
  27. symconst,symbase,symtype,symdef,symsym,
  28. { ppu }
  29. ppu,
  30. { assembler }
  31. aasmtai
  32. ;
  33. {****************************************************************************
  34. Symtable types
  35. ****************************************************************************}
  36. type
  37. tstoredsymtable = class(tsymtable)
  38. private
  39. b_needs_init_final : boolean;
  40. procedure _needs_init_final(p : tnamedindexitem;arg:pointer);
  41. procedure check_forward(sym : TNamedIndexItem;arg:pointer);
  42. procedure labeldefined(p : TNamedIndexItem;arg:pointer);
  43. procedure varsymbolused(p : TNamedIndexItem;arg:pointer);
  44. procedure TestPrivate(p : TNamedIndexItem;arg:pointer);
  45. procedure objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
  46. procedure unchain_overloads(p : TNamedIndexItem;arg:pointer);
  47. procedure loaddefs(ppufile:tcompilerppufile);
  48. procedure loadsyms(ppufile:tcompilerppufile);
  49. procedure reset_def(def:Tnamedindexitem;arg:pointer);
  50. procedure writedefs(ppufile:tcompilerppufile);
  51. procedure writesyms(ppufile:tcompilerppufile);
  52. public
  53. { load/write }
  54. procedure ppuload(ppufile:tcompilerppufile);virtual;
  55. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  56. procedure load_references(ppufile:tcompilerppufile;locals:boolean);virtual;
  57. procedure write_references(ppufile:tcompilerppufile;locals:boolean);virtual;
  58. procedure buildderef;virtual;
  59. procedure buildderefimpl;virtual;
  60. procedure deref;virtual;
  61. procedure derefimpl;virtual;
  62. procedure duplicatesym(dupsym,sym:tsymentry);
  63. procedure insert(sym : tsymentry);override;
  64. procedure reset_all_defs;virtual;
  65. function speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;override;
  66. procedure allsymbolsused;
  67. procedure allprivatesused;
  68. procedure check_forwards;
  69. procedure checklabels;
  70. function needs_init_final : boolean;
  71. procedure unchain_overloaded;
  72. {$ifdef GDB}
  73. procedure concatstabto(asmlist : taasmoutput);virtual;
  74. function getnewtypecount : word; override;
  75. {$endif GDB}
  76. procedure testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
  77. end;
  78. tabstractrecordsymtable = class(tstoredsymtable)
  79. public
  80. datasize : aint;
  81. usefieldalignment, { alignment to use for fields (PACKRECORDS value), -1 is C style }
  82. recordalignment, { alignment required when inserting this record }
  83. fieldalignment, { alignment current alignment used when fields are inserted }
  84. padalignment : shortint; { size to a multiple of which the symtable has to be rounded up }
  85. constructor create(const n:string;usealign:shortint);
  86. procedure ppuload(ppufile:tcompilerppufile);override;
  87. procedure ppuwrite(ppufile:tcompilerppufile);override;
  88. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  89. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  90. procedure insertfield(sym:tfieldvarsym;addsym:boolean);
  91. procedure addalignmentpadding;
  92. end;
  93. trecordsymtable = class(tabstractrecordsymtable)
  94. public
  95. constructor create(usealign:shortint);
  96. procedure insertunionst(unionst : trecordsymtable;offset : longint);
  97. end;
  98. tobjectsymtable = class(tabstractrecordsymtable)
  99. public
  100. constructor create(const n:string;usealign:shortint);
  101. procedure insert(sym : tsymentry);override;
  102. end;
  103. tabstractlocalsymtable = class(tstoredsymtable)
  104. public
  105. procedure ppuwrite(ppufile:tcompilerppufile);override;
  106. end;
  107. tlocalsymtable = class(tabstractlocalsymtable)
  108. public
  109. constructor create(level:byte);
  110. procedure insert(sym : tsymentry);override;
  111. end;
  112. tparasymtable = class(tabstractlocalsymtable)
  113. public
  114. constructor create(level:byte);
  115. procedure insert(sym : tsymentry);override;
  116. end;
  117. tabstractunitsymtable = class(tstoredsymtable)
  118. public
  119. {$ifdef GDB}
  120. dbx_count : longint;
  121. prev_dbx_counter : plongint;
  122. dbx_count_ok : boolean;
  123. {$endif GDB}
  124. constructor create(const n : string);
  125. {$ifdef GDB}
  126. procedure concattypestabto(asmlist : taasmoutput);
  127. {$endif GDB}
  128. end;
  129. tglobalsymtable = class(tabstractunitsymtable)
  130. public
  131. unittypecount : word;
  132. constructor create(const n : string);
  133. procedure ppuload(ppufile:tcompilerppufile);override;
  134. procedure ppuwrite(ppufile:tcompilerppufile);override;
  135. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  136. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  137. procedure insert(sym : tsymentry);override;
  138. {$ifdef GDB}
  139. function getnewtypecount : word; override;
  140. {$endif}
  141. end;
  142. tstaticsymtable = class(tabstractunitsymtable)
  143. public
  144. constructor create(const n : string);
  145. procedure ppuload(ppufile:tcompilerppufile);override;
  146. procedure ppuwrite(ppufile:tcompilerppufile);override;
  147. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  148. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  149. procedure insert(sym : tsymentry);override;
  150. end;
  151. twithsymtable = class(tsymtable)
  152. withrefnode : pointer; { tnode }
  153. constructor create(aowner:tdef;asymsearch:TDictionary;refnode:pointer{tnode});
  154. destructor destroy;override;
  155. procedure clear;override;
  156. end;
  157. tstt_exceptsymtable = class(tsymtable)
  158. public
  159. constructor create;
  160. end;
  161. var
  162. constsymtable : tsymtable; { symtable were the constants can be inserted }
  163. systemunit : tglobalsymtable; { pointer to the system unit }
  164. {****************************************************************************
  165. Functions
  166. ****************************************************************************}
  167. {*** Misc ***}
  168. procedure globaldef(const s : string;var t:ttype);
  169. function findunitsymtable(st:tsymtable):tsymtable;
  170. function FullTypeName(def,otherdef:tdef):string;
  171. procedure incompatibletypes(def1,def2:tdef);
  172. {*** Search ***}
  173. function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  174. function searchsym_type(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  175. function searchsymonlyin(p : tsymtable;const s : stringid):tsym;
  176. function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
  177. function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
  178. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
  179. function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
  180. function searchsysvar(const s: stringid; var srsym: tsym; var symowner: tsymtable): boolean;
  181. function search_class_member(pd : tobjectdef;const s : string):tsym;
  182. function search_assignment_operator(from_def,to_def:Tdef):Tprocdef;
  183. {*** Object Helpers ***}
  184. procedure search_class_overloads(aprocsym : tprocsym);
  185. function search_default_property(pd : tobjectdef) : tpropertysym;
  186. {*** symtable stack ***}
  187. {$ifdef DEBUG}
  188. procedure test_symtablestack;
  189. procedure list_symtablestack;
  190. {$endif DEBUG}
  191. {$ifdef UNITALIASES}
  192. type
  193. punit_alias = ^tunit_alias;
  194. tunit_alias = object(TNamedIndexItem)
  195. newname : pstring;
  196. constructor init(const n:string);
  197. destructor done;virtual;
  198. end;
  199. var
  200. unitaliases : pdictionary;
  201. procedure addunitalias(const n:string);
  202. function getunitalias(const n:string):string;
  203. {$endif UNITALIASES}
  204. {*** Init / Done ***}
  205. procedure InitSymtable;
  206. procedure DoneSymtable;
  207. const
  208. overloaded_names : array [NOTOKEN..last_overloaded] of string[16] =
  209. ('error',
  210. 'plus','minus','star','slash','equal',
  211. 'greater','lower','greater_or_equal',
  212. 'lower_or_equal',
  213. 'sym_diff','starstar',
  214. 'as','is','in','or',
  215. 'and','div','mod','not','shl','shr','xor',
  216. 'assign');
  217. implementation
  218. uses
  219. { global }
  220. verbose,globals,
  221. { target }
  222. systems,
  223. { symtable }
  224. symutil,defcmp,
  225. { module }
  226. fmodule,
  227. {$ifdef GDB}
  228. gdb,
  229. {$endif GDB}
  230. { codegen }
  231. procinfo
  232. ;
  233. var
  234. dupnr : longint; { unique number for duplicate symbols }
  235. {*****************************************************************************
  236. TStoredSymtable
  237. *****************************************************************************}
  238. procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
  239. begin
  240. { load definitions }
  241. loaddefs(ppufile);
  242. { load symbols }
  243. loadsyms(ppufile);
  244. end;
  245. procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile);
  246. begin
  247. { write definitions }
  248. writedefs(ppufile);
  249. { write symbols }
  250. writesyms(ppufile);
  251. end;
  252. procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile);
  253. var
  254. hp : tdef;
  255. b : byte;
  256. begin
  257. { load start of definition section, which holds the amount of defs }
  258. if ppufile.readentry<>ibstartdefs then
  259. Message(unit_f_ppu_read_error);
  260. ppufile.getlongint;
  261. { read definitions }
  262. repeat
  263. b:=ppufile.readentry;
  264. case b of
  265. ibpointerdef : hp:=tpointerdef.ppuload(ppufile);
  266. ibarraydef : hp:=tarraydef.ppuload(ppufile);
  267. iborddef : hp:=torddef.ppuload(ppufile);
  268. ibfloatdef : hp:=tfloatdef.ppuload(ppufile);
  269. ibprocdef : hp:=tprocdef.ppuload(ppufile);
  270. ibshortstringdef : hp:=tstringdef.loadshort(ppufile);
  271. iblongstringdef : hp:=tstringdef.loadlong(ppufile);
  272. {$ifdef ansistring_bits}
  273. ibansistring16def : hp:=tstringdef.loadansi(ppufile,sb_16);
  274. ibansistring32def : hp:=tstringdef.loadansi(ppufile,sb_32);
  275. ibansistring64def : hp:=tstringdef.loadansi(ppufile,sb_64);
  276. {$else}
  277. ibansistringdef : hp:=tstringdef.loadansi(ppufile);
  278. {$endif}
  279. ibwidestringdef : hp:=tstringdef.loadwide(ppufile);
  280. ibrecorddef : hp:=trecorddef.ppuload(ppufile);
  281. ibobjectdef : hp:=tobjectdef.ppuload(ppufile);
  282. ibenumdef : hp:=tenumdef.ppuload(ppufile);
  283. ibsetdef : hp:=tsetdef.ppuload(ppufile);
  284. ibprocvardef : hp:=tprocvardef.ppuload(ppufile);
  285. ibfiledef : hp:=tfiledef.ppuload(ppufile);
  286. ibclassrefdef : hp:=tclassrefdef.ppuload(ppufile);
  287. ibformaldef : hp:=tformaldef.ppuload(ppufile);
  288. ibvariantdef : hp:=tvariantdef.ppuload(ppufile);
  289. ibenddefs : break;
  290. ibend : Message(unit_f_ppu_read_error);
  291. else
  292. Message1(unit_f_ppu_invalid_entry,tostr(b));
  293. end;
  294. hp.owner:=self;
  295. defindex.insert(hp);
  296. until false;
  297. end;
  298. procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile);
  299. var
  300. b : byte;
  301. sym : tsym;
  302. begin
  303. { load start of definition section, which holds the amount of defs }
  304. if ppufile.readentry<>ibstartsyms then
  305. Message(unit_f_ppu_read_error);
  306. { skip amount of symbols, not used currently }
  307. ppufile.getlongint;
  308. { now read the symbols }
  309. repeat
  310. b:=ppufile.readentry;
  311. case b of
  312. ibtypesym : sym:=ttypesym.ppuload(ppufile);
  313. ibprocsym : sym:=tprocsym.ppuload(ppufile);
  314. ibconstsym : sym:=tconstsym.ppuload(ppufile);
  315. ibglobalvarsym : sym:=tglobalvarsym.ppuload(ppufile);
  316. iblocalvarsym : sym:=tlocalvarsym.ppuload(ppufile);
  317. ibparavarsym : sym:=tparavarsym.ppuload(ppufile);
  318. ibfieldvarsym : sym:=tfieldvarsym.ppuload(ppufile);
  319. ibabsolutevarsym : sym:=tabsolutevarsym.ppuload(ppufile);
  320. ibenumsym : sym:=tenumsym.ppuload(ppufile);
  321. ibtypedconstsym : sym:=ttypedconstsym.ppuload(ppufile);
  322. ibpropertysym : sym:=tpropertysym.ppuload(ppufile);
  323. ibunitsym : sym:=tunitsym.ppuload(ppufile);
  324. iblabelsym : sym:=tlabelsym.ppuload(ppufile);
  325. ibsyssym : sym:=tsyssym.ppuload(ppufile);
  326. ibrttisym : sym:=trttisym.ppuload(ppufile);
  327. ibendsyms : break;
  328. ibend : Message(unit_f_ppu_read_error);
  329. else
  330. Message1(unit_f_ppu_invalid_entry,tostr(b));
  331. end;
  332. sym.owner:=self;
  333. symindex.insert(sym);
  334. symsearch.insert(sym);
  335. until false;
  336. end;
  337. procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile);
  338. var
  339. pd : tstoreddef;
  340. begin
  341. { each definition get a number, write then the amount of defs to the
  342. ibstartdef entry }
  343. ppufile.putlongint(defindex.count);
  344. ppufile.writeentry(ibstartdefs);
  345. { now write the definition }
  346. pd:=tstoreddef(defindex.first);
  347. while assigned(pd) do
  348. begin
  349. pd.ppuwrite(ppufile);
  350. pd:=tstoreddef(pd.indexnext);
  351. end;
  352. { write end of definitions }
  353. ppufile.writeentry(ibenddefs);
  354. end;
  355. procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile);
  356. var
  357. pd : Tstoredsym;
  358. begin
  359. { each definition get a number, write then the amount of syms and the
  360. datasize to the ibsymdef entry }
  361. ppufile.putlongint(symindex.count);
  362. ppufile.writeentry(ibstartsyms);
  363. { foreach is used to write all symbols }
  364. pd:=Tstoredsym(symindex.first);
  365. while assigned(pd) do
  366. begin
  367. pd.ppuwrite(ppufile);
  368. pd:=Tstoredsym(pd.indexnext);
  369. end;
  370. { end of symbols }
  371. ppufile.writeentry(ibendsyms);
  372. end;
  373. procedure tstoredsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  374. var
  375. b : byte;
  376. d : tderef;
  377. sym : Tsym;
  378. prdef : tstoreddef;
  379. begin
  380. b:=ppufile.readentry;
  381. if b <> ibbeginsymtablebrowser then
  382. Message1(unit_f_ppu_invalid_entry,tostr(b));
  383. repeat
  384. b:=ppufile.readentry;
  385. case b of
  386. ibsymref :
  387. begin
  388. ppufile.getderef(d);
  389. sym:=Tsym(d.resolve);
  390. if assigned(sym) then
  391. sym.load_references(ppufile,locals);
  392. end;
  393. ibdefref :
  394. begin
  395. ppufile.getderef(d);
  396. prdef:=tstoreddef(d.resolve);
  397. if assigned(prdef) then
  398. begin
  399. if prdef.deftype<>procdef then
  400. Message(unit_f_ppu_read_error);
  401. tprocdef(prdef).load_references(ppufile,locals);
  402. end;
  403. end;
  404. ibendsymtablebrowser :
  405. break;
  406. else
  407. Message1(unit_f_ppu_invalid_entry,tostr(b));
  408. end;
  409. until false;
  410. end;
  411. procedure tstoredsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  412. var
  413. pd : Tsym;
  414. begin
  415. ppufile.writeentry(ibbeginsymtablebrowser);
  416. { write all symbols }
  417. pd:=Tsym(symindex.first);
  418. while assigned(pd) do
  419. begin
  420. pd.write_references(ppufile,locals);
  421. pd:=Tsym(pd.indexnext);
  422. end;
  423. ppufile.writeentry(ibendsymtablebrowser);
  424. end;
  425. procedure tstoredsymtable.buildderef;
  426. var
  427. hp : tdef;
  428. hs : tsym;
  429. begin
  430. { interface definitions }
  431. hp:=tdef(defindex.first);
  432. while assigned(hp) do
  433. begin
  434. hp.buildderef;
  435. hp:=tdef(hp.indexnext);
  436. end;
  437. { interface symbols }
  438. hs:=tsym(symindex.first);
  439. while assigned(hs) do
  440. begin
  441. hs.buildderef;
  442. hs:=tsym(hs.indexnext);
  443. end;
  444. end;
  445. procedure tstoredsymtable.buildderefimpl;
  446. var
  447. hp : tdef;
  448. begin
  449. { definitions }
  450. hp:=tdef(defindex.first);
  451. while assigned(hp) do
  452. begin
  453. hp.buildderefimpl;
  454. hp:=tdef(hp.indexnext);
  455. end;
  456. end;
  457. procedure tstoredsymtable.deref;
  458. var
  459. hp : tdef;
  460. hs : tsym;
  461. begin
  462. { first deref the interface ttype symbols. This is needs
  463. to be done before the interface defs are derefed, because
  464. the interface defs can contain references to the type symbols
  465. which then already need to contain a resolved restype field (PFV) }
  466. hs:=tsym(symindex.first);
  467. while assigned(hs) do
  468. begin
  469. if hs.typ=typesym then
  470. hs.deref;
  471. hs:=tsym(hs.indexnext);
  472. end;
  473. { deref the interface definitions }
  474. hp:=tdef(defindex.first);
  475. while assigned(hp) do
  476. begin
  477. hp.deref;
  478. hp:=tdef(hp.indexnext);
  479. end;
  480. { deref the interface symbols }
  481. hs:=tsym(symindex.first);
  482. while assigned(hs) do
  483. begin
  484. if hs.typ<>typesym then
  485. hs.deref;
  486. hs:=tsym(hs.indexnext);
  487. end;
  488. end;
  489. procedure tstoredsymtable.derefimpl;
  490. var
  491. hp : tdef;
  492. begin
  493. { definitions }
  494. hp:=tdef(defindex.first);
  495. while assigned(hp) do
  496. begin
  497. hp.derefimpl;
  498. hp:=tdef(hp.indexnext);
  499. end;
  500. end;
  501. procedure tstoredsymtable.duplicatesym(dupsym,sym:tsymentry);
  502. var
  503. st : tsymtable;
  504. begin
  505. Message1(sym_e_duplicate_id,tsym(sym).realname);
  506. st:=findunitsymtable(sym.owner);
  507. with tsym(sym).fileinfo do
  508. begin
  509. if assigned(st) and (st.unitid<>0) then
  510. Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line))
  511. else
  512. Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line));
  513. end;
  514. { Rename duplicate sym to an unreachable name, but it can be
  515. inserted in the symtable without errors }
  516. if assigned(dupsym) then
  517. begin
  518. inc(dupnr);
  519. dupsym.name:='dup'+tostr(dupnr)+dupsym.name;
  520. end;
  521. end;
  522. procedure tstoredsymtable.insert(sym:tsymentry);
  523. var
  524. hsym : tsym;
  525. begin
  526. { set owner and sym indexnb }
  527. sym.owner:=self;
  528. { check the current symtable }
  529. hsym:=tsym(search(sym.name));
  530. if assigned(hsym) then
  531. begin
  532. { in TP and Delphi you can have a local with the
  533. same name as the function, the function is then hidden for
  534. the user. (Under delphi it can still be accessed using result),
  535. but don't allow hiding of RESULT }
  536. if (m_duplicate_names in aktmodeswitches) and
  537. (sym.typ in [localvarsym,paravarsym,absolutevarsym]) and
  538. (vo_is_funcret in tabstractvarsym(sym).varoptions) and
  539. not((m_result in aktmodeswitches) and
  540. (vo_is_result in tabstractvarsym(sym).varoptions)) then
  541. sym.name:='hidden'+sym.name
  542. else
  543. DuplicateSym(sym,hsym);
  544. end;
  545. { register definition of typesym }
  546. if (sym.typ = typesym) and
  547. assigned(ttypesym(sym).restype.def) then
  548. begin
  549. if not(assigned(ttypesym(sym).restype.def.owner)) and
  550. (ttypesym(sym).restype.def.deftype<>errordef) then
  551. registerdef(ttypesym(sym).restype.def);
  552. end;
  553. { insert in index and search hash }
  554. symindex.insert(sym);
  555. symsearch.insert(sym);
  556. end;
  557. function tstoredsymtable.speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;
  558. var
  559. hp : Tsym;
  560. newref : tref;
  561. begin
  562. hp:=Tsym(inherited speedsearch(s,speedvalue));
  563. if assigned(hp) then
  564. begin
  565. { reject non static members in static procedures }
  566. if (symtabletype=objectsymtable) and
  567. not(sp_static in hp.symoptions) and
  568. allow_only_static then
  569. Message(sym_e_only_static_in_static);
  570. { unit uses count }
  571. if (unitid<>0) and
  572. (symtabletype = globalsymtable) and
  573. assigned(current_module) and
  574. (unitid<current_module.mapsize) and
  575. assigned(current_module.map[unitid].unitsym) then
  576. inc(current_module.map[unitid].unitsym.refs);
  577. { unitsym are only loaded for browsing PM }
  578. { this was buggy anyway because we could use }
  579. { unitsyms from other units in _USES !! }
  580. {if (symtabletype=unitsymtable) and (hp.typ=unitsym) and
  581. assigned(current_module) and (current_module.globalsymtable<>.load) then
  582. hp:=nil;}
  583. if make_ref and (cs_browser in aktmoduleswitches) then
  584. begin
  585. newref:=tref.create(hp.lastref,@akttokenpos);
  586. { for symbols that are in tables without browser info or syssyms }
  587. if hp.refcount=0 then
  588. begin
  589. hp.defref:=newref;
  590. hp.lastref:=newref;
  591. end
  592. else
  593. if resolving_forward and assigned(hp.defref) then
  594. { put it as second reference }
  595. begin
  596. newref.nextref:=hp.defref.nextref;
  597. hp.defref.nextref:=newref;
  598. hp.lastref.nextref:=nil;
  599. end
  600. else
  601. hp.lastref:=newref;
  602. inc(hp.refcount);
  603. end;
  604. if make_ref then
  605. inc(hp.refs);
  606. end; { value was not found }
  607. speedsearch:=hp;
  608. end;
  609. {**************************************
  610. Callbacks
  611. **************************************}
  612. procedure TStoredSymtable.check_forward(sym : TNamedIndexItem;arg:pointer);
  613. begin
  614. if tsym(sym).typ=procsym then
  615. tprocsym(sym).check_forward
  616. { check also object method table }
  617. { we needn't to test the def list }
  618. { because each object has to have a type sym }
  619. else
  620. if (tsym(sym).typ=typesym) and
  621. assigned(ttypesym(sym).restype.def) and
  622. (ttypesym(sym).restype.def.deftype=objectdef) then
  623. tobjectdef(ttypesym(sym).restype.def).check_forwards;
  624. end;
  625. procedure TStoredSymtable.labeldefined(p : TNamedIndexItem;arg:pointer);
  626. begin
  627. if (tsym(p).typ=labelsym) and
  628. not(tlabelsym(p).defined) then
  629. begin
  630. if tlabelsym(p).used then
  631. Message1(sym_e_label_used_and_not_defined,tlabelsym(p).realname)
  632. else
  633. Message1(sym_w_label_not_defined,tlabelsym(p).realname);
  634. end;
  635. end;
  636. procedure TStoredSymtable.varsymbolused(p : TNamedIndexItem;arg:pointer);
  637. begin
  638. if (tsym(p).typ in [globalvarsym,localvarsym,paravarsym,fieldvarsym]) and
  639. ((tsym(p).owner.symtabletype in
  640. [parasymtable,localsymtable,objectsymtable,staticsymtable])) then
  641. begin
  642. { unused symbol should be reported only if no }
  643. { error is reported }
  644. { if the symbol is in a register it is used }
  645. { also don't count the value parameters which have local copies }
  646. { also don't claim for high param of open parameters (PM) }
  647. if (Errorcount<>0) or
  648. (vo_is_hidden in tabstractvarsym(p).varoptions) then
  649. exit;
  650. if (tstoredsym(p).refs=0) then
  651. begin
  652. if (vo_is_funcret in tabstractvarsym(p).varoptions) then
  653. begin
  654. { don't warn about the result of constructors }
  655. if (tsym(p).owner.symtabletype<>localsymtable) or
  656. (tprocdef(tsym(p).owner.defowner).proctypeoption<>potype_constructor) then
  657. MessagePos(tsym(p).fileinfo,sym_w_function_result_not_set)
  658. end
  659. else if (tsym(p).owner.symtabletype=parasymtable) then
  660. MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_not_used,tsym(p).realname)
  661. else if (tsym(p).owner.symtabletype=objectsymtable) then
  662. MessagePos2(tsym(p).fileinfo,sym_n_private_identifier_not_used,tsym(p).owner.realname^,tsym(p).realname)
  663. else
  664. MessagePos1(tsym(p).fileinfo,sym_n_local_identifier_not_used,tsym(p).realname);
  665. end
  666. else if tabstractvarsym(p).varstate=vs_assigned then
  667. begin
  668. if (tsym(p).owner.symtabletype=parasymtable) then
  669. begin
  670. if not(tabstractvarsym(p).varspez in [vs_var,vs_out]) and
  671. not(vo_is_funcret in tabstractvarsym(p).varoptions) then
  672. MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_only_set,tsym(p).realname)
  673. end
  674. else if (tsym(p).owner.symtabletype=objectsymtable) then
  675. MessagePos2(tsym(p).fileinfo,sym_n_private_identifier_only_set,tsym(p).owner.realname^,tsym(p).realname)
  676. else if not(vo_is_exported in tabstractvarsym(p).varoptions) and
  677. not(vo_is_funcret in tabstractvarsym(p).varoptions) then
  678. MessagePos1(tsym(p).fileinfo,sym_n_local_identifier_only_set,tsym(p).realname);
  679. end;
  680. end
  681. else if ((tsym(p).owner.symtabletype in
  682. [objectsymtable,parasymtable,localsymtable,staticsymtable])) then
  683. begin
  684. if (Errorcount<>0) or
  685. (sp_internal in tsym(p).symoptions) then
  686. exit;
  687. { do not claim for inherited private fields !! }
  688. if (Tsym(p).refs=0) and (tsym(p).owner.symtabletype=objectsymtable) then
  689. MessagePos2(tsym(p).fileinfo,sym_n_private_method_not_used,tsym(p).owner.realname^,tsym(p).realname)
  690. { units references are problematic }
  691. else
  692. begin
  693. if (Tsym(p).refs=0) and
  694. not(tsym(p).typ in [enumsym,unitsym]) and
  695. not(is_funcret_sym(tsym(p))) and
  696. (
  697. (tsym(p).typ<>procsym) or
  698. ((tsym(p).owner.symtabletype=staticsymtable) and
  699. not current_module.is_unit)
  700. ) then
  701. MessagePos2(tsym(p).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(p).typ],tsym(p).realname);
  702. end;
  703. end;
  704. end;
  705. procedure TStoredSymtable.TestPrivate(p : TNamedIndexItem;arg:pointer);
  706. begin
  707. if sp_private in tsym(p).symoptions then
  708. varsymbolused(p,arg);
  709. end;
  710. procedure TStoredSymtable.objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
  711. begin
  712. {
  713. Don't test simple object aliases PM
  714. }
  715. if (tsym(p).typ=typesym) and
  716. (ttypesym(p).restype.def.deftype=objectdef) and
  717. (ttypesym(p).restype.def.typesym=tsym(p)) then
  718. tobjectdef(ttypesym(p).restype.def).symtable.foreach(@TestPrivate,nil);
  719. end;
  720. procedure tstoredsymtable.unchain_overloads(p : TNamedIndexItem;arg:pointer);
  721. begin
  722. if tsym(p).typ=procsym then
  723. tprocsym(p).unchain_overload;
  724. end;
  725. procedure Tstoredsymtable.reset_def(def:Tnamedindexitem;arg:pointer);
  726. begin
  727. Tstoreddef(def).reset;
  728. end;
  729. {$ifdef GDB}
  730. function tstoredsymtable.getnewtypecount : word;
  731. begin
  732. getnewtypecount:=pglobaltypecount^;
  733. inc(pglobaltypecount^);
  734. end;
  735. {$endif GDB}
  736. {***********************************************
  737. Process all entries
  738. ***********************************************}
  739. procedure Tstoredsymtable.reset_all_defs;
  740. begin
  741. defindex.foreach(@reset_def,nil);
  742. end;
  743. { checks, if all procsyms and methods are defined }
  744. procedure tstoredsymtable.check_forwards;
  745. begin
  746. foreach(@check_forward,nil);
  747. end;
  748. procedure tstoredsymtable.checklabels;
  749. begin
  750. foreach(@labeldefined,nil);
  751. end;
  752. procedure tstoredsymtable.allsymbolsused;
  753. begin
  754. foreach(@varsymbolused,nil);
  755. end;
  756. procedure tstoredsymtable.allprivatesused;
  757. begin
  758. foreach(@objectprivatesymbolused,nil);
  759. end;
  760. procedure tstoredsymtable.unchain_overloaded;
  761. begin
  762. foreach(@unchain_overloads,nil);
  763. end;
  764. {$ifdef GDB}
  765. procedure tstoredsymtable.concatstabto(asmlist : taasmoutput);
  766. var
  767. stabstr : Pchar;
  768. p : tsym;
  769. begin
  770. p:=tsym(symindex.first);
  771. while assigned(p) do
  772. begin
  773. { Procsym and typesym are already written }
  774. if not(Tsym(p).typ in [procsym,typesym]) then
  775. begin
  776. if not Tsym(p).isstabwritten then
  777. begin
  778. stabstr:=Tsym(p).stabstring;
  779. if stabstr<>nil then
  780. asmlist.concat(Tai_stabs.create(stabstr));
  781. Tsym(p).isstabwritten:=true;
  782. end;
  783. end;
  784. p:=tsym(p.indexnext);
  785. end;
  786. end;
  787. {$endif}
  788. procedure TStoredSymtable._needs_init_final(p : tnamedindexitem;arg:pointer);
  789. begin
  790. if b_needs_init_final then
  791. exit;
  792. case tsym(p).typ of
  793. fieldvarsym,
  794. globalvarsym,
  795. localvarsym,
  796. paravarsym :
  797. begin
  798. if not(is_class(tabstractvarsym(p).vartype.def)) and
  799. tstoreddef(tabstractvarsym(p).vartype.def).needs_inittable then
  800. b_needs_init_final:=true;
  801. end;
  802. typedconstsym :
  803. begin
  804. if ttypedconstsym(p).is_writable and
  805. tstoreddef(ttypedconstsym(p).typedconsttype.def).needs_inittable then
  806. b_needs_init_final:=true;
  807. end;
  808. end;
  809. end;
  810. { returns true, if p contains data which needs init/final code }
  811. function tstoredsymtable.needs_init_final : boolean;
  812. begin
  813. b_needs_init_final:=false;
  814. foreach(@_needs_init_final,nil);
  815. needs_init_final:=b_needs_init_final;
  816. end;
  817. {****************************************************************************
  818. TAbstractRecordSymtable
  819. ****************************************************************************}
  820. constructor tabstractrecordsymtable.create(const n:string;usealign:shortint);
  821. begin
  822. inherited create(n);
  823. datasize:=0;
  824. recordalignment:=1;
  825. usefieldalignment:=usealign;
  826. padalignment:=1;
  827. { recordalign -1 means C record packing, that starts
  828. with an alignment of 1 }
  829. if usealign=-1 then
  830. fieldalignment:=1
  831. else
  832. fieldalignment:=usealign;
  833. end;
  834. procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile);
  835. var
  836. storesymtable : tsymtable;
  837. begin
  838. storesymtable:=aktrecordsymtable;
  839. aktrecordsymtable:=self;
  840. inherited ppuload(ppufile);
  841. aktrecordsymtable:=storesymtable;
  842. end;
  843. procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile);
  844. var
  845. oldtyp : byte;
  846. storesymtable : tsymtable;
  847. begin
  848. storesymtable:=aktrecordsymtable;
  849. aktrecordsymtable:=self;
  850. oldtyp:=ppufile.entrytyp;
  851. ppufile.entrytyp:=subentryid;
  852. inherited ppuwrite(ppufile);
  853. ppufile.entrytyp:=oldtyp;
  854. aktrecordsymtable:=storesymtable;
  855. end;
  856. procedure tabstractrecordsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  857. var
  858. storesymtable : tsymtable;
  859. begin
  860. storesymtable:=aktrecordsymtable;
  861. aktrecordsymtable:=self;
  862. inherited load_references(ppufile,locals);
  863. aktrecordsymtable:=storesymtable;
  864. end;
  865. procedure tabstractrecordsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  866. var
  867. storesymtable : tsymtable;
  868. begin
  869. storesymtable:=aktrecordsymtable;
  870. aktrecordsymtable:=self;
  871. inherited write_references(ppufile,locals);
  872. aktrecordsymtable:=storesymtable;
  873. end;
  874. procedure tabstractrecordsymtable.insertfield(sym : tfieldvarsym;addsym:boolean);
  875. var
  876. l : aint;
  877. varalignrecord,
  878. varalignfield,
  879. varalign : longint;
  880. vardef : tdef;
  881. begin
  882. if addsym then
  883. insert(sym);
  884. { this symbol can't be loaded to a register }
  885. sym.varregable:=vr_none;
  886. { Calculate field offset }
  887. l:=sym.getsize;
  888. vardef:=sym.vartype.def;
  889. varalign:=vardef.alignment;
  890. { Calc the alignment size for C style records }
  891. if (usefieldalignment=-1) then
  892. begin
  893. if (varalign>4) and
  894. ((varalign mod 4)<>0) and
  895. (vardef.deftype=arraydef) then
  896. Message1(sym_w_wrong_C_pack,vardef.typename);
  897. if varalign=0 then
  898. varalign:=l;
  899. if (fieldalignment<aktalignment.maxCrecordalign) then
  900. begin
  901. if (varalign>16) and (fieldalignment<32) then
  902. fieldalignment:=32
  903. else if (varalign>12) and (fieldalignment<16) then
  904. fieldalignment:=16
  905. { 12 is needed for long double }
  906. else if (varalign>8) and (fieldalignment<12) then
  907. fieldalignment:=12
  908. else if (varalign>4) and (fieldalignment<8) then
  909. fieldalignment:=8
  910. else if (varalign>2) and (fieldalignment<4) then
  911. fieldalignment:=4
  912. else if (varalign>1) and (fieldalignment<2) then
  913. fieldalignment:=2;
  914. end;
  915. fieldalignment:=min(fieldalignment,aktalignment.maxCrecordalign);
  916. end;
  917. if varalign=0 then
  918. varalign:=size_2_align(l);
  919. varalignfield:=used_align(varalign,aktalignment.recordalignmin,fieldalignment);
  920. sym.fieldoffset:=align(datasize,varalignfield);
  921. if (aword(l)+sym.fieldoffset)>high(aint) then
  922. begin
  923. Message(sym_e_segment_too_large);
  924. datasize:=high(aint);
  925. end
  926. else
  927. datasize:=sym.fieldoffset+l;
  928. { Calc alignment needed for this record }
  929. if (usefieldalignment=-1) then
  930. varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
  931. else
  932. if (usefieldalignment=0) then
  933. varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.recordalignmax)
  934. else
  935. begin
  936. { packrecords is set explicit, ignore recordalignmax limit }
  937. varalignrecord:=used_align(varalign,aktalignment.recordalignmin,usefieldalignment);
  938. end;
  939. recordalignment:=max(recordalignment,varalignrecord);
  940. end;
  941. procedure tabstractrecordsymtable.addalignmentpadding;
  942. begin
  943. { make the record size aligned correctly so it can be
  944. used as elements in an array. For C records we
  945. use the fieldalignment, because that is updated with the
  946. used alignment. }
  947. if (padalignment = 1) then
  948. if usefieldalignment=-1 then
  949. padalignment:=fieldalignment
  950. else
  951. padalignment:=recordalignment;
  952. datasize:=align(datasize,padalignment);
  953. end;
  954. {****************************************************************************
  955. TRecordSymtable
  956. ****************************************************************************}
  957. constructor trecordsymtable.create(usealign:shortint);
  958. begin
  959. inherited create('',usealign);
  960. symtabletype:=recordsymtable;
  961. end;
  962. { this procedure is reserved for inserting case variant into
  963. a record symtable }
  964. { the offset is the location of the start of the variant
  965. and datasize and dataalignment corresponds to
  966. the complete size (see code in pdecl unit) PM }
  967. procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : longint);
  968. var
  969. ps,nps : tfieldvarsym;
  970. pd,npd : tdef;
  971. varalignrecord,varalign,
  972. storesize,storealign : longint;
  973. begin
  974. storesize:=datasize;
  975. storealign:=fieldalignment;
  976. datasize:=offset;
  977. ps:=tfieldvarsym(unionst.symindex.first);
  978. while assigned(ps) do
  979. begin
  980. nps:=tfieldvarsym(ps.indexnext);
  981. { remove from current symtable }
  982. unionst.symindex.deleteindex(ps);
  983. ps.left:=nil;
  984. ps.right:=nil;
  985. { add to this record }
  986. ps.owner:=self;
  987. datasize:=ps.fieldoffset+offset;
  988. symindex.insert(ps);
  989. symsearch.insert(ps);
  990. { update address }
  991. ps.fieldoffset:=datasize;
  992. { update alignment of this record }
  993. varalign:=ps.vartype.def.alignment;
  994. if varalign=0 then
  995. varalign:=size_2_align(ps.getsize);
  996. varalignrecord:=used_align(varalign,aktalignment.recordalignmin,fieldalignment);
  997. recordalignment:=max(recordalignment,varalignrecord);
  998. { next }
  999. ps:=nps;
  1000. end;
  1001. pd:=tdef(unionst.defindex.first);
  1002. while assigned(pd) do
  1003. begin
  1004. npd:=tdef(pd.indexnext);
  1005. unionst.defindex.deleteindex(pd);
  1006. pd.left:=nil;
  1007. pd.right:=nil;
  1008. registerdef(pd);
  1009. pd:=npd;
  1010. end;
  1011. datasize:=storesize;
  1012. fieldalignment:=storealign;
  1013. end;
  1014. {****************************************************************************
  1015. TObjectSymtable
  1016. ****************************************************************************}
  1017. constructor tobjectsymtable.create(const n:string;usealign:shortint);
  1018. begin
  1019. inherited create(n,usealign);
  1020. symtabletype:=objectsymtable;
  1021. end;
  1022. procedure tobjectsymtable.insert(sym:tsymentry);
  1023. var
  1024. hsym : tsym;
  1025. begin
  1026. { check for duplicate field id in inherited classes }
  1027. if (sym.typ=fieldvarsym) and
  1028. assigned(defowner) and
  1029. (
  1030. not(m_delphi in aktmodeswitches) or
  1031. is_object(tdef(defowner))
  1032. ) then
  1033. begin
  1034. { but private ids can be reused }
  1035. hsym:=search_class_member(tobjectdef(defowner),sym.name);
  1036. if assigned(hsym) and
  1037. Tsym(hsym).is_visible_for_object(tobjectdef(defowner)) then
  1038. DuplicateSym(sym,hsym);
  1039. end;
  1040. inherited insert(sym);
  1041. end;
  1042. {****************************************************************************
  1043. TAbstractLocalSymtable
  1044. ****************************************************************************}
  1045. procedure tabstractlocalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1046. var
  1047. oldtyp : byte;
  1048. begin
  1049. oldtyp:=ppufile.entrytyp;
  1050. ppufile.entrytyp:=subentryid;
  1051. { write definitions }
  1052. writedefs(ppufile);
  1053. { write symbols }
  1054. writesyms(ppufile);
  1055. ppufile.entrytyp:=oldtyp;
  1056. end;
  1057. {****************************************************************************
  1058. TLocalSymtable
  1059. ****************************************************************************}
  1060. constructor tlocalsymtable.create(level:byte);
  1061. begin
  1062. inherited create('');
  1063. symtabletype:=localsymtable;
  1064. symtablelevel:=level;
  1065. end;
  1066. procedure tlocalsymtable.insert(sym:tsymentry);
  1067. var
  1068. hsym : tsym;
  1069. begin
  1070. { need to hide function result? }
  1071. hsym:=tsym(search(sym.name));
  1072. if assigned(hsym) then
  1073. begin
  1074. { a local and the function can have the same
  1075. name in TP and Delphi, but RESULT not }
  1076. if (m_duplicate_names in aktmodeswitches) and
  1077. (hsym.typ in [absolutevarsym,localvarsym]) and
  1078. (vo_is_funcret in tabstractvarsym(hsym).varoptions) and
  1079. not((m_result in aktmodeswitches) and
  1080. (vo_is_result in tabstractvarsym(hsym).varoptions)) then
  1081. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1082. else
  1083. DuplicateSym(sym,hsym);
  1084. end;
  1085. if assigned(next) and
  1086. (next.symtabletype=parasymtable) then
  1087. begin
  1088. { check para symtable }
  1089. hsym:=tsym(next.search(sym.name));
  1090. if assigned(hsym) then
  1091. begin
  1092. { a local and the function can have the same
  1093. name in TP and Delphi, but RESULT not }
  1094. if (m_duplicate_names in aktmodeswitches) and
  1095. (sym.typ in [absolutevarsym,paravarsym]) and
  1096. (vo_is_funcret in tabstractvarsym(sym).varoptions) and
  1097. not((m_result in aktmodeswitches) and
  1098. (vo_is_result in tabstractvarsym(sym).varoptions)) then
  1099. sym.name:='hidden'+sym.name
  1100. else
  1101. DuplicateSym(sym,hsym);
  1102. end;
  1103. { check for duplicate id in local symtable of methods }
  1104. if assigned(next.next) and
  1105. { funcretsym is allowed !! }
  1106. (not is_funcret_sym(sym)) and
  1107. (next.next.symtabletype=objectsymtable) then
  1108. begin
  1109. hsym:=search_class_member(tobjectdef(next.next.defowner),sym.name);
  1110. if assigned(hsym) and
  1111. { private ids can be reused }
  1112. (hsym.is_visible_for_object(tobjectdef(next.next.defowner)) or
  1113. (hsym.owner.defowner.owner.symtabletype<>globalsymtable)) then
  1114. begin
  1115. { delphi allows to reuse the names in a class, but not
  1116. in object (tp7 compatible) }
  1117. if not((m_delphi in aktmodeswitches) and
  1118. is_class(tdef(next.next.defowner))) then
  1119. DuplicateSym(sym,hsym);
  1120. end;
  1121. end;
  1122. end;
  1123. inherited insert(sym);
  1124. end;
  1125. {****************************************************************************
  1126. TParaSymtable
  1127. ****************************************************************************}
  1128. constructor tparasymtable.create(level:byte);
  1129. begin
  1130. inherited create('');
  1131. symtabletype:=parasymtable;
  1132. symtablelevel:=level;
  1133. end;
  1134. procedure tparasymtable.insert(sym:tsymentry);
  1135. var
  1136. hsym : tsym;
  1137. begin
  1138. { check for duplicate id in para symtable of methods }
  1139. if assigned(next) and
  1140. (next.symtabletype=objectsymtable) and
  1141. { funcretsym is allowed }
  1142. (not is_funcret_sym(sym)) then
  1143. begin
  1144. hsym:=search_class_member(tobjectdef(next.defowner),sym.name);
  1145. { private ids can be reused }
  1146. if assigned(hsym) and
  1147. Tsym(hsym).is_visible_for_object(tobjectdef(next.defowner)) then
  1148. begin
  1149. { delphi allows to reuse the names in a class, but not
  1150. in object (tp7 compatible) }
  1151. if not((m_delphi in aktmodeswitches) and
  1152. is_class_or_interface(tobjectdef(next.defowner))) then
  1153. DuplicateSym(sym,hsym);
  1154. end;
  1155. end;
  1156. inherited insert(sym);
  1157. end;
  1158. {****************************************************************************
  1159. TAbstractUnitSymtable
  1160. ****************************************************************************}
  1161. constructor tabstractunitsymtable.create(const n : string);
  1162. begin
  1163. inherited create(n);
  1164. symsearch.usehash;
  1165. {$ifdef GDB}
  1166. { reset GDB things }
  1167. prev_dbx_counter := dbx_counter;
  1168. dbx_counter := nil;
  1169. dbx_count := -1;
  1170. {$endif GDB}
  1171. end;
  1172. {$ifdef GDB}
  1173. procedure tabstractunitsymtable.concattypestabto(asmlist : taasmoutput);
  1174. procedure dowritestabs(asmlist:taasmoutput;st:tsymtable);
  1175. var
  1176. p : tstoreddef;
  1177. begin
  1178. p:=tstoreddef(st.defindex.first);
  1179. while assigned(p) do
  1180. begin
  1181. { also insert local types for the current unit }
  1182. if (unitid=0) and
  1183. (p.deftype=procdef) and
  1184. assigned(tprocdef(p).localst) then
  1185. dowritestabs(asmlist,tprocdef(p).localst);
  1186. if (p.stab_state=stab_state_used) then
  1187. p.concatstabto(asmlist);
  1188. p:=tstoreddef(p.indexnext);
  1189. end;
  1190. end;
  1191. var
  1192. old_writing_def_stabs : boolean;
  1193. prev_dbx_count : plongint;
  1194. begin
  1195. if not assigned(name) then
  1196. name := stringdup('Main_program');
  1197. asmList.concat(tai_comment.Create(strpnew('Begin unit '+name^+' has index '+tostr(unitid))));
  1198. if cs_gdb_dbx in aktglobalswitches then
  1199. begin
  1200. if dbx_count_ok then
  1201. begin
  1202. asmList.concat(tai_comment.Create(strpnew('"repeated" unit '+name^
  1203. +' has index '+tostr(unitid)+' dbx count = '+tostr(dbx_count))));
  1204. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1205. +tostr(N_EXCL)+',0,0,'+tostr(dbx_count))));
  1206. exit;
  1207. end
  1208. else if (current_module.globalsymtable<>self) then
  1209. begin
  1210. prev_dbx_count := dbx_counter;
  1211. dbx_counter := nil;
  1212. do_count_dbx:=false;
  1213. if (symtabletype = globalsymtable) and (unitid<>0) then
  1214. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
  1215. dbx_counter := @dbx_count;
  1216. dbx_count:=0;
  1217. do_count_dbx:=assigned(dbx_counter);
  1218. end;
  1219. end;
  1220. old_writing_def_stabs:=writing_def_stabs;
  1221. writing_def_stabs:=true;
  1222. dowritestabs(asmlist,self);
  1223. writing_def_stabs:=old_writing_def_stabs;
  1224. if cs_gdb_dbx in aktglobalswitches then
  1225. begin
  1226. if (current_module.globalsymtable<>self) then
  1227. begin
  1228. dbx_counter := prev_dbx_count;
  1229. do_count_dbx:=false;
  1230. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1231. +tostr(N_EINCL)+',0,0,0')));
  1232. do_count_dbx:=assigned(dbx_counter);
  1233. dbx_count_ok := {true}false;
  1234. end;
  1235. end;
  1236. asmList.concat(tai_comment.Create(strpnew('End unit '+name^+' has index '+tostr(unitid))));
  1237. end;
  1238. {$endif GDB}
  1239. {****************************************************************************
  1240. TStaticSymtable
  1241. ****************************************************************************}
  1242. constructor tstaticsymtable.create(const n : string);
  1243. begin
  1244. inherited create(n);
  1245. symtabletype:=staticsymtable;
  1246. symtablelevel:=main_program_level;
  1247. end;
  1248. procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile);
  1249. begin
  1250. next:=symtablestack;
  1251. symtablestack:=self;
  1252. inherited ppuload(ppufile);
  1253. { now we can deref the syms and defs }
  1254. deref;
  1255. { restore symtablestack }
  1256. symtablestack:=next;
  1257. end;
  1258. procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile);
  1259. begin
  1260. inherited ppuwrite(ppufile);
  1261. end;
  1262. procedure tstaticsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  1263. begin
  1264. inherited load_references(ppufile,locals);
  1265. end;
  1266. procedure tstaticsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  1267. begin
  1268. inherited write_references(ppufile,locals);
  1269. end;
  1270. procedure tstaticsymtable.insert(sym:tsymentry);
  1271. var
  1272. hsym : tsym;
  1273. begin
  1274. { also check the global symtable }
  1275. if assigned(next) and
  1276. (next.unitid=0) then
  1277. begin
  1278. hsym:=tsym(next.search(sym.name));
  1279. if assigned(hsym) then
  1280. begin
  1281. { Delphi you can have a symbol with the same name as the
  1282. unit, the unit can then not be accessed anymore using
  1283. <unit>.<id>, so we can hide the symbol }
  1284. if (m_duplicate_names in aktmodeswitches) and
  1285. (hsym.typ=symconst.unitsym) then
  1286. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1287. else
  1288. DuplicateSym(sym,hsym);
  1289. end;
  1290. end;
  1291. inherited insert(sym);
  1292. end;
  1293. {****************************************************************************
  1294. TGlobalSymtable
  1295. ****************************************************************************}
  1296. constructor tglobalsymtable.create(const n : string);
  1297. begin
  1298. inherited create(n);
  1299. symtabletype:=globalsymtable;
  1300. symtablelevel:=main_program_level;
  1301. unitid:=0;
  1302. {$ifdef GDB}
  1303. if cs_gdb_dbx in aktglobalswitches then
  1304. begin
  1305. dbx_count := 0;
  1306. unittypecount:=1;
  1307. pglobaltypecount := @unittypecount;
  1308. {unitid:=current_module.unitcount;}
  1309. {debugList.concat(tai_comment.Create(strpnew('Global '+name^+' has index '+tostr(unitid))));
  1310. debugList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));}
  1311. {inc(current_module.unitcount);}
  1312. { we can't use dbx_vcount, because we don't know
  1313. if the object file will be loaded before or afeter PM }
  1314. dbx_count_ok:=false;
  1315. dbx_counter:=@dbx_count;
  1316. do_count_dbx:=true;
  1317. end;
  1318. {$endif GDB}
  1319. end;
  1320. procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile);
  1321. {$ifdef GDB}
  1322. var
  1323. b : byte;
  1324. {$endif GDB}
  1325. begin
  1326. {$ifdef GDB}
  1327. if cs_gdb_dbx in aktglobalswitches then
  1328. begin
  1329. UnitTypeCount:=1;
  1330. PglobalTypeCount:=@UnitTypeCount;
  1331. end;
  1332. {$endif GDB}
  1333. next:=symtablestack;
  1334. symtablestack:=self;
  1335. inherited ppuload(ppufile);
  1336. { now we can deref the syms and defs }
  1337. deref;
  1338. { restore symtablestack }
  1339. symtablestack:=next;
  1340. { read dbx count }
  1341. {$ifdef GDB}
  1342. if (current_module.flags and uf_has_dbx)<>0 then
  1343. begin
  1344. b:=ppufile.readentry;
  1345. if b<>ibdbxcount then
  1346. Message(unit_f_ppu_dbx_count_problem)
  1347. else
  1348. dbx_count:=ppufile.getlongint;
  1349. {$IfDef EXTDEBUG}
  1350. writeln('Read dbx_count ',dbx_count,' in unit ',name^,'.ppu');
  1351. {$ENDIF EXTDEBUG}
  1352. { we can't use dbx_vcount, because we don't know
  1353. if the object file will be loaded before or afeter PM }
  1354. dbx_count_ok := {true}false;
  1355. end
  1356. else
  1357. begin
  1358. dbx_count:=-1;
  1359. dbx_count_ok:=false;
  1360. end;
  1361. {$endif GDB}
  1362. end;
  1363. procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1364. begin
  1365. { write the symtable entries }
  1366. inherited ppuwrite(ppufile);
  1367. { write dbx count }
  1368. {$ifdef GDB}
  1369. if cs_gdb_dbx in aktglobalswitches then
  1370. begin
  1371. {$IfDef EXTDEBUG}
  1372. writeln('Writing dbx_count ',dbx_count,' in unit ',name^,'.ppu');
  1373. {$ENDIF EXTDEBUG}
  1374. ppufile.do_crc:=false;
  1375. ppufile.putlongint(dbx_count);
  1376. ppufile.writeentry(ibdbxcount);
  1377. ppufile.do_crc:=true;
  1378. end;
  1379. {$endif GDB}
  1380. end;
  1381. procedure tglobalsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  1382. begin
  1383. inherited load_references(ppufile,locals);
  1384. end;
  1385. procedure tglobalsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  1386. begin
  1387. inherited write_references(ppufile,locals);
  1388. end;
  1389. procedure tglobalsymtable.insert(sym:tsymentry);
  1390. var
  1391. hsym : tsym;
  1392. begin
  1393. { also check the global symtable }
  1394. if assigned(next) and
  1395. (next.unitid=0) then
  1396. begin
  1397. hsym:=tsym(next.search(sym.name));
  1398. if assigned(hsym) then
  1399. begin
  1400. { Delphi you can have a symbol with the same name as the
  1401. unit, the unit can then not be accessed anymore using
  1402. <unit>.<id>, so we can hide the symbol }
  1403. if (m_duplicate_names in aktmodeswitches) and
  1404. (hsym.typ=symconst.unitsym) then
  1405. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1406. else
  1407. DuplicateSym(sym,hsym);
  1408. end;
  1409. end;
  1410. hsym:=tsym(search(sym.name));
  1411. if assigned(hsym) then
  1412. begin
  1413. { Delphi you can have a symbol with the same name as the
  1414. unit, the unit can then not be accessed anymore using
  1415. <unit>.<id>, so we can hide the symbol }
  1416. if (m_duplicate_names in aktmodeswitches) and
  1417. (hsym.typ=symconst.unitsym) then
  1418. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1419. else
  1420. DuplicateSym(sym,hsym);
  1421. end;
  1422. inherited insert(sym);
  1423. end;
  1424. {$ifdef GDB}
  1425. function tglobalsymtable.getnewtypecount : word;
  1426. begin
  1427. if not (cs_gdb_dbx in aktglobalswitches) then
  1428. getnewtypecount:=inherited getnewtypecount
  1429. else
  1430. begin
  1431. getnewtypecount:=unittypecount;
  1432. inc(unittypecount);
  1433. end;
  1434. end;
  1435. {$endif}
  1436. {****************************************************************************
  1437. TWITHSYMTABLE
  1438. ****************************************************************************}
  1439. constructor twithsymtable.create(aowner:tdef;asymsearch:TDictionary;refnode:pointer{tnode});
  1440. begin
  1441. inherited create('');
  1442. symtabletype:=withsymtable;
  1443. withrefnode:=refnode;
  1444. { we don't need the symsearch }
  1445. symsearch.free;
  1446. { set the defaults }
  1447. symsearch:=asymsearch;
  1448. defowner:=aowner;
  1449. end;
  1450. destructor twithsymtable.destroy;
  1451. begin
  1452. tobject(withrefnode).free;
  1453. symsearch:=nil;
  1454. inherited destroy;
  1455. end;
  1456. procedure twithsymtable.clear;
  1457. begin
  1458. { remove no entry from a withsymtable as it is only a pointer to the
  1459. recorddef or objectdef symtable }
  1460. end;
  1461. {****************************************************************************
  1462. TSTT_ExceptionSymtable
  1463. ****************************************************************************}
  1464. constructor tstt_exceptsymtable.create;
  1465. begin
  1466. inherited create('');
  1467. symtabletype:=stt_exceptsymtable;
  1468. end;
  1469. {*****************************************************************************
  1470. Helper Routines
  1471. *****************************************************************************}
  1472. function findunitsymtable(st:tsymtable):tsymtable;
  1473. begin
  1474. findunitsymtable:=nil;
  1475. repeat
  1476. if not assigned(st) then
  1477. internalerror(5566561);
  1478. case st.symtabletype of
  1479. localsymtable,
  1480. parasymtable,
  1481. staticsymtable :
  1482. exit;
  1483. globalsymtable :
  1484. begin
  1485. findunitsymtable:=st;
  1486. exit;
  1487. end;
  1488. objectsymtable :
  1489. st:=st.defowner.owner;
  1490. recordsymtable :
  1491. begin
  1492. { don't continue when the current
  1493. symtable is used for variant records }
  1494. if trecorddef(st.defowner).isunion then
  1495. begin
  1496. findunitsymtable:=nil;
  1497. exit;
  1498. end
  1499. else
  1500. st:=st.defowner.owner;
  1501. end;
  1502. else
  1503. internalerror(5566562);
  1504. end;
  1505. until false;
  1506. end;
  1507. function FullTypeName(def,otherdef:tdef):string;
  1508. var
  1509. s1,s2 : string;
  1510. begin
  1511. s1:=def.typename;
  1512. { When the names are the same try to include the unit name }
  1513. if assigned(otherdef) and
  1514. (def.owner.symtabletype in [globalsymtable,staticsymtable]) then
  1515. begin
  1516. s2:=otherdef.typename;
  1517. if upper(s1)=upper(s2) then
  1518. s1:=def.owner.realname^+'.'+s1;
  1519. end;
  1520. FullTypeName:=s1;
  1521. end;
  1522. procedure incompatibletypes(def1,def2:tdef);
  1523. begin
  1524. { When there is an errordef there is already an error message show }
  1525. if (def2.deftype=errordef) or
  1526. (def1.deftype=errordef) then
  1527. exit;
  1528. CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
  1529. end;
  1530. {*****************************************************************************
  1531. Search
  1532. *****************************************************************************}
  1533. function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  1534. var
  1535. speedvalue : cardinal;
  1536. topclass : tobjectdef;
  1537. begin
  1538. speedvalue:=getspeedvalue(s);
  1539. srsymtable:=symtablestack;
  1540. while assigned(srsymtable) do
  1541. begin
  1542. srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
  1543. if assigned(srsym) then
  1544. begin
  1545. topclass:=nil;
  1546. { use the class from withsymtable only when it is
  1547. defined in this unit }
  1548. if (srsymtable.symtabletype=withsymtable) and
  1549. assigned(srsymtable.defowner) and
  1550. (srsymtable.defowner.deftype=objectdef) and
  1551. (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1552. (srsymtable.defowner.owner.unitid=0) then
  1553. topclass:=tobjectdef(srsymtable.defowner)
  1554. else
  1555. begin
  1556. if assigned(current_procinfo) then
  1557. topclass:=current_procinfo.procdef._class;
  1558. end;
  1559. if (not assigned(topclass)) or
  1560. Tsym(srsym).is_visible_for_object(topclass) then
  1561. begin
  1562. searchsym:=true;
  1563. exit;
  1564. end;
  1565. end;
  1566. srsymtable:=srsymtable.next;
  1567. end;
  1568. searchsym:=false;
  1569. end;
  1570. function searchsym_type(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  1571. var
  1572. speedvalue : cardinal;
  1573. begin
  1574. speedvalue:=getspeedvalue(s);
  1575. srsymtable:=symtablestack;
  1576. while assigned(srsymtable) do
  1577. begin
  1578. {
  1579. It is not possible to have type defintions in:
  1580. records
  1581. objects
  1582. parameters
  1583. }
  1584. if not(srsymtable.symtabletype in [recordsymtable,objectsymtable,parasymtable]) then
  1585. begin
  1586. srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
  1587. if assigned(srsym) and
  1588. (not assigned(current_procinfo) or
  1589. Tsym(srsym).is_visible_for_object(current_procinfo.procdef._class)) then
  1590. begin
  1591. result:=true;
  1592. exit;
  1593. end
  1594. end;
  1595. srsymtable:=srsymtable.next;
  1596. end;
  1597. result:=false;
  1598. end;
  1599. function searchsymonlyin(p : tsymtable;const s : stringid):tsym;
  1600. var
  1601. srsym : tsym;
  1602. begin
  1603. { the caller have to take care if srsym=nil }
  1604. if assigned(p) then
  1605. begin
  1606. srsym:=tsym(p.search(s));
  1607. if assigned(srsym) then
  1608. begin
  1609. searchsymonlyin:=srsym;
  1610. exit;
  1611. end;
  1612. { also check in the local symtbale if it exists }
  1613. if (p=tsymtable(current_module.globalsymtable)) then
  1614. begin
  1615. srsym:=tsym(current_module.localsymtable.search(s));
  1616. if assigned(srsym) then
  1617. begin
  1618. searchsymonlyin:=srsym;
  1619. exit;
  1620. end;
  1621. end
  1622. end;
  1623. searchsymonlyin:=nil;
  1624. end;
  1625. function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
  1626. var
  1627. speedvalue : cardinal;
  1628. topclassh : tobjectdef;
  1629. sym : tsym;
  1630. begin
  1631. speedvalue:=getspeedvalue(s);
  1632. { when the class passed is defined in this unit we
  1633. need to use the scope of that class. This is a trick
  1634. that can be used to access protected members in other
  1635. units. At least kylix supports it this way (PFV) }
  1636. if assigned(classh) and
  1637. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1638. (classh.owner.unitid=0) then
  1639. topclassh:=classh
  1640. else
  1641. begin
  1642. if assigned(current_procinfo) then
  1643. topclassh:=current_procinfo.procdef._class
  1644. else
  1645. topclassh:=nil;
  1646. end;
  1647. sym:=nil;
  1648. while assigned(classh) do
  1649. begin
  1650. sym:=tsym(classh.symtable.speedsearch(s,speedvalue));
  1651. if assigned(sym) and
  1652. Tsym(sym).is_visible_for_object(topclassh) then
  1653. break;
  1654. classh:=classh.childof;
  1655. end;
  1656. searchsym_in_class:=sym;
  1657. end;
  1658. function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
  1659. var
  1660. topclassh : tobjectdef;
  1661. def : tdef;
  1662. sym : tsym;
  1663. begin
  1664. { when the class passed is defined in this unit we
  1665. need to use the scope of that class. This is a trick
  1666. that can be used to access protected members in other
  1667. units. At least kylix supports it this way (PFV) }
  1668. if assigned(classh) and
  1669. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1670. (classh.owner.unitid=0) then
  1671. topclassh:=classh
  1672. else
  1673. begin
  1674. if assigned(current_procinfo) then
  1675. topclassh:=current_procinfo.procdef._class
  1676. else
  1677. topclassh:=nil;
  1678. end;
  1679. sym:=nil;
  1680. def:=nil;
  1681. while assigned(classh) do
  1682. begin
  1683. def:=tdef(classh.symtable.defindex.first);
  1684. while assigned(def) do
  1685. begin
  1686. if (def.deftype=procdef) and
  1687. (po_msgint in tprocdef(def).procoptions) and
  1688. (tprocdef(def).messageinf.i=i) then
  1689. begin
  1690. sym:=tprocdef(def).procsym;
  1691. if assigned(topclassh) then
  1692. begin
  1693. if tprocdef(def).is_visible_for_object(topclassh) then
  1694. break;
  1695. end
  1696. else
  1697. break;
  1698. end;
  1699. def:=tdef(def.indexnext);
  1700. end;
  1701. if assigned(sym) then
  1702. break;
  1703. classh:=classh.childof;
  1704. end;
  1705. searchsym_in_class_by_msgint:=sym;
  1706. end;
  1707. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
  1708. var
  1709. topclassh : tobjectdef;
  1710. def : tdef;
  1711. sym : tsym;
  1712. begin
  1713. { when the class passed is defined in this unit we
  1714. need to use the scope of that class. This is a trick
  1715. that can be used to access protected members in other
  1716. units. At least kylix supports it this way (PFV) }
  1717. if assigned(classh) and
  1718. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1719. (classh.owner.unitid=0) then
  1720. topclassh:=classh
  1721. else
  1722. begin
  1723. if assigned(current_procinfo) then
  1724. topclassh:=current_procinfo.procdef._class
  1725. else
  1726. topclassh:=nil;
  1727. end;
  1728. sym:=nil;
  1729. def:=nil;
  1730. while assigned(classh) do
  1731. begin
  1732. def:=tdef(classh.symtable.defindex.first);
  1733. while assigned(def) do
  1734. begin
  1735. if (def.deftype=procdef) and
  1736. (po_msgstr in tprocdef(def).procoptions) and
  1737. (tprocdef(def).messageinf.str=s) then
  1738. begin
  1739. sym:=tprocdef(def).procsym;
  1740. if assigned(topclassh) then
  1741. begin
  1742. if tprocdef(def).is_visible_for_object(topclassh) then
  1743. break;
  1744. end
  1745. else
  1746. break;
  1747. end;
  1748. def:=tdef(def.indexnext);
  1749. end;
  1750. if assigned(sym) then
  1751. break;
  1752. classh:=classh.childof;
  1753. end;
  1754. searchsym_in_class_by_msgstr:=sym;
  1755. end;
  1756. function search_assignment_operator(from_def,to_def:Tdef):Tprocdef;
  1757. var st:Tsymtable;
  1758. sym:Tprocsym;
  1759. sv:cardinal;
  1760. begin
  1761. st:=symtablestack;
  1762. sv:=getspeedvalue('assign');
  1763. while st<>nil do
  1764. begin
  1765. sym:=Tprocsym(st.speedsearch('assign',sv));
  1766. if sym<>nil then
  1767. begin
  1768. if sym.typ<>procsym then
  1769. internalerror(200402031);
  1770. search_assignment_operator:=sym.search_procdef_assignment_operator(from_def,to_def);
  1771. if search_assignment_operator<>nil then
  1772. break;
  1773. end;
  1774. st:=st.next;
  1775. end;
  1776. end;
  1777. function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
  1778. var
  1779. symowner: tsymtable;
  1780. begin
  1781. if not(cs_compilesystem in aktmoduleswitches) then
  1782. srsym := ttypesym(searchsymonlyin(systemunit,s))
  1783. else
  1784. searchsym(s,tsym(srsym),symowner);
  1785. searchsystype :=
  1786. assigned(srsym) and
  1787. (srsym.typ = typesym);
  1788. end;
  1789. function searchsysvar(const s: stringid; var srsym: tsym; var symowner: tsymtable): boolean;
  1790. begin
  1791. if not(cs_compilesystem in aktmoduleswitches) then
  1792. begin
  1793. srsym := searchsymonlyin(systemunit,s);
  1794. symowner := systemunit;
  1795. end
  1796. else
  1797. searchsym(s,tsym(srsym),symowner);
  1798. searchsysvar :=
  1799. assigned(srsym) and
  1800. (srsym.typ = globalvarsym);
  1801. end;
  1802. function search_class_member(pd : tobjectdef;const s : string):tsym;
  1803. { searches n in symtable of pd and all anchestors }
  1804. var
  1805. speedvalue : cardinal;
  1806. srsym : tsym;
  1807. begin
  1808. speedvalue:=getspeedvalue(s);
  1809. while assigned(pd) do
  1810. begin
  1811. srsym:=tsym(pd.symtable.speedsearch(s,speedvalue));
  1812. if assigned(srsym) then
  1813. begin
  1814. search_class_member:=srsym;
  1815. exit;
  1816. end;
  1817. pd:=pd.childof;
  1818. end;
  1819. search_class_member:=nil;
  1820. end;
  1821. {*****************************************************************************
  1822. Definition Helpers
  1823. *****************************************************************************}
  1824. procedure globaldef(const s : string;var t:ttype);
  1825. var st : string;
  1826. symt : tsymtable;
  1827. srsym : tsym;
  1828. srsymtable : tsymtable;
  1829. begin
  1830. srsym := nil;
  1831. if pos('.',s) > 0 then
  1832. begin
  1833. st := copy(s,1,pos('.',s)-1);
  1834. searchsym(st,srsym,srsymtable);
  1835. st := copy(s,pos('.',s)+1,255);
  1836. if assigned(srsym) then
  1837. begin
  1838. if srsym.typ = unitsym then
  1839. begin
  1840. symt := tunitsym(srsym).unitsymtable;
  1841. srsym := tsym(symt.search(st));
  1842. end else srsym := nil;
  1843. end;
  1844. end else st := s;
  1845. if srsym = nil then
  1846. searchsym(st,srsym,srsymtable);
  1847. if srsym = nil then
  1848. srsym:=searchsymonlyin(systemunit,st);
  1849. if (not assigned(srsym)) or
  1850. (srsym.typ<>typesym) then
  1851. begin
  1852. Message(type_e_type_id_expected);
  1853. t:=generrortype;
  1854. exit;
  1855. end;
  1856. t := ttypesym(srsym).restype;
  1857. end;
  1858. {****************************************************************************
  1859. Object Helpers
  1860. ****************************************************************************}
  1861. procedure search_class_overloads(aprocsym : tprocsym);
  1862. { searches n in symtable of pd and all anchestors }
  1863. var
  1864. speedvalue : cardinal;
  1865. srsym : tprocsym;
  1866. s : string;
  1867. objdef : tobjectdef;
  1868. begin
  1869. if aprocsym.overloadchecked then
  1870. exit;
  1871. aprocsym.overloadchecked:=true;
  1872. if (aprocsym.owner.symtabletype<>objectsymtable) then
  1873. internalerror(200111021);
  1874. objdef:=tobjectdef(aprocsym.owner.defowner);
  1875. { we start in the parent }
  1876. if not assigned(objdef.childof) then
  1877. exit;
  1878. objdef:=objdef.childof;
  1879. s:=aprocsym.name;
  1880. speedvalue:=getspeedvalue(s);
  1881. while assigned(objdef) do
  1882. begin
  1883. srsym:=tprocsym(objdef.symtable.speedsearch(s,speedvalue));
  1884. if assigned(srsym) then
  1885. begin
  1886. if (srsym.typ<>procsym) then
  1887. internalerror(200111022);
  1888. if srsym.is_visible_for_object(tobjectdef(aprocsym.owner.defowner)) then
  1889. begin
  1890. srsym.add_para_match_to(Aprocsym,[cpo_ignorehidden,cpo_allowdefaults]);
  1891. { we can stop if the overloads were already added
  1892. for the found symbol }
  1893. if srsym.overloadchecked then
  1894. break;
  1895. end;
  1896. end;
  1897. { next parent }
  1898. objdef:=objdef.childof;
  1899. end;
  1900. end;
  1901. procedure tstoredsymtable.testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
  1902. begin
  1903. if (tsym(p).typ=propertysym) and
  1904. (ppo_defaultproperty in tpropertysym(p).propoptions) then
  1905. ppointer(arg)^:=p;
  1906. end;
  1907. function search_default_property(pd : tobjectdef) : tpropertysym;
  1908. { returns the default property of a class, searches also anchestors }
  1909. var
  1910. _defaultprop : tpropertysym;
  1911. begin
  1912. _defaultprop:=nil;
  1913. while assigned(pd) do
  1914. begin
  1915. pd.symtable.foreach(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop);
  1916. if assigned(_defaultprop) then
  1917. break;
  1918. pd:=pd.childof;
  1919. end;
  1920. search_default_property:=_defaultprop;
  1921. end;
  1922. {$ifdef UNITALIASES}
  1923. {****************************************************************************
  1924. TUNIT_ALIAS
  1925. ****************************************************************************}
  1926. constructor tunit_alias.create(const n:string);
  1927. var
  1928. i : longint;
  1929. begin
  1930. i:=pos('=',n);
  1931. if i=0 then
  1932. fail;
  1933. inherited createname(Copy(n,1,i-1));
  1934. newname:=stringdup(Copy(n,i+1,255));
  1935. end;
  1936. destructor tunit_alias.destroy;
  1937. begin
  1938. stringdispose(newname);
  1939. inherited destroy;
  1940. end;
  1941. procedure addunitalias(const n:string);
  1942. begin
  1943. unitaliases^.insert(tunit_alias,init(Upper(n))));
  1944. end;
  1945. function getunitalias(const n:string):string;
  1946. var
  1947. p : punit_alias;
  1948. begin
  1949. p:=punit_alias(unitaliases^.search(Upper(n)));
  1950. if assigned(p) then
  1951. getunitalias:=punit_alias(p).newname^
  1952. else
  1953. getunitalias:=n;
  1954. end;
  1955. {$endif UNITALIASES}
  1956. {****************************************************************************
  1957. Symtable Stack
  1958. ****************************************************************************}
  1959. {$ifdef DEBUG}
  1960. procedure test_symtablestack;
  1961. var
  1962. p : tsymtable;
  1963. i : longint;
  1964. begin
  1965. p:=symtablestack;
  1966. i:=0;
  1967. while assigned(p) do
  1968. begin
  1969. inc(i);
  1970. p:=p.next;
  1971. if i>500 then
  1972. Message(sym_f_internal_error_in_symtablestack);
  1973. end;
  1974. end;
  1975. procedure list_symtablestack;
  1976. var
  1977. p : tsymtable;
  1978. i : longint;
  1979. begin
  1980. p:=symtablestack;
  1981. i:=0;
  1982. while assigned(p) do
  1983. begin
  1984. inc(i);
  1985. writeln(i,' ',p.name^);
  1986. p:=p.next;
  1987. if i>500 then
  1988. Message(sym_f_internal_error_in_symtablestack);
  1989. end;
  1990. end;
  1991. {$endif DEBUG}
  1992. {****************************************************************************
  1993. Init/Done Symtable
  1994. ****************************************************************************}
  1995. procedure InitSymtable;
  1996. begin
  1997. { Reset symbolstack }
  1998. registerdef:=false;
  1999. symtablestack:=nil;
  2000. systemunit:=nil;
  2001. {$ifdef GDB}
  2002. globaltypecount:=1;
  2003. pglobaltypecount:=@globaltypecount;
  2004. {$endif GDB}
  2005. { create error syms and def }
  2006. generrorsym:=terrorsym.create;
  2007. generrortype.setdef(terrordef.create);
  2008. {$ifdef UNITALIASES}
  2009. { unit aliases }
  2010. unitaliases:=tdictionary.create;
  2011. {$endif}
  2012. dupnr:=0;
  2013. end;
  2014. procedure DoneSymtable;
  2015. begin
  2016. generrorsym.free;
  2017. generrortype.def.free;
  2018. {$ifdef UNITALIASES}
  2019. unitaliases.free;
  2020. {$endif}
  2021. end;
  2022. end.
  2023. {
  2024. $Log$
  2025. Revision 1.162 2004-11-08 22:09:59 peter
  2026. * tvarsym splitted
  2027. Revision 1.161 2004/11/05 21:16:55 peter
  2028. * rename duplicate symbols and insert with unique name in the
  2029. symtable
  2030. Revision 1.160 2004/11/01 23:30:11 peter
  2031. * support > 32bit accesses for x86_64
  2032. * rewrote array size checking to support 64bit
  2033. Revision 1.159 2004/10/15 09:14:17 mazen
  2034. - remove $IFDEF DELPHI and related code
  2035. - remove $IFDEF FPCPROCVAR and related code
  2036. Revision 1.158 2004/10/12 19:51:13 peter
  2037. * all checking for visibility is now done by is_visible_for_object
  2038. Revision 1.157 2004/10/11 15:48:15 peter
  2039. * small regvar for para fixes
  2040. * function tvarsym.is_regvar added
  2041. * tvarsym.getvaluesize removed, use getsize instead
  2042. Revision 1.156 2004/10/08 17:09:43 peter
  2043. * tvarsym.varregable added, split vo_regable from varoptions
  2044. Revision 1.155 2004/08/17 16:29:21 jonas
  2045. + padalgingment field for recordsymtables (saved by recorddefs)
  2046. + support for Macintosh PowerPC alignment (if the first field of a record
  2047. or union has an alignment > 4, then the record or union size must be
  2048. padded to a multiple of this size)
  2049. Revision 1.154 2004/08/15 15:05:16 peter
  2050. * fixed padding of records to alignment
  2051. Revision 1.153 2004/08/15 13:30:18 florian
  2052. * fixed alignment of variant records
  2053. * more alignment problems fixed
  2054. Revision 1.152 2004/07/09 22:17:32 peter
  2055. * revert has_localst patch
  2056. * replace aktstaticsymtable/aktglobalsymtable with current_module
  2057. Revision 1.151 2004/06/23 16:22:45 peter
  2058. * include unit name in error messages when types are the same
  2059. Revision 1.150 2004/06/20 08:55:30 florian
  2060. * logs truncated
  2061. Revision 1.149 2004/06/16 20:07:09 florian
  2062. * dwarf branch merged
  2063. Revision 1.148 2004/05/25 18:50:50 peter
  2064. * check for 2gb limit when inserting record fields
  2065. Revision 1.147 2004/05/23 20:56:14 peter
  2066. * don't generate incompatible types when there is an errordef
  2067. Revision 1.146 2004/05/22 23:34:28 peter
  2068. tai_regalloc.allocation changed to ratype to notify rgobj of register size changes
  2069. Revision 1.145 2004/04/29 19:56:37 daniel
  2070. * Prepare compiler infrastructure for multiple ansistring types
  2071. }