symtable.pas 84 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544
  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,symppu,
  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 unitsymbolused(p : TNamedIndexItem;arg:pointer);
  44. procedure varsymbolused(p : TNamedIndexItem;arg:pointer);
  45. procedure TestPrivate(p : TNamedIndexItem;arg:pointer);
  46. procedure objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
  47. {$ifdef GDB}
  48. private
  49. procedure concatstab(p : TNamedIndexItem;arg:pointer);
  50. procedure resetstab(p : TNamedIndexItem;arg:pointer);
  51. procedure concattypestab(p : TNamedIndexItem;arg:pointer);
  52. {$endif}
  53. procedure unchain_overloads(p : TNamedIndexItem;arg:pointer);
  54. procedure loaddefs(ppufile:tcompilerppufile);
  55. procedure loadsyms(ppufile:tcompilerppufile);
  56. procedure writedefs(ppufile:tcompilerppufile);
  57. procedure writesyms(ppufile:tcompilerppufile);
  58. public
  59. { load/write }
  60. procedure ppuload(ppufile:tcompilerppufile);virtual;
  61. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  62. procedure load_references(ppufile:tcompilerppufile;locals:boolean);virtual;
  63. procedure write_references(ppufile:tcompilerppufile;locals:boolean);virtual;
  64. procedure deref;virtual;
  65. procedure derefimpl;virtual;
  66. procedure insert(sym : tsymentry);override;
  67. function speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;override;
  68. procedure allsymbolsused;
  69. procedure allprivatesused;
  70. procedure allunitsused;
  71. procedure check_forwards;
  72. procedure checklabels;
  73. function needs_init_final : boolean;
  74. procedure unchain_overloaded;
  75. procedure chainoperators;
  76. {$ifdef GDB}
  77. procedure concatstabto(asmlist : taasmoutput);virtual;
  78. function getnewtypecount : word; override;
  79. {$endif GDB}
  80. procedure testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
  81. end;
  82. tabstractrecordsymtable = class(tstoredsymtable)
  83. public
  84. datasize : longint;
  85. dataalignment : byte;
  86. constructor create(const n:string);
  87. procedure ppuload(ppufile:tcompilerppufile);override;
  88. procedure ppuwrite(ppufile:tcompilerppufile);override;
  89. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  90. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  91. procedure insertfield(sym:tvarsym;addsym:boolean);
  92. end;
  93. trecordsymtable = class(tabstractrecordsymtable)
  94. public
  95. constructor create;
  96. procedure insert_in(tsymt : trecordsymtable;offset : longint);
  97. end;
  98. tobjectsymtable = class(tabstractrecordsymtable)
  99. public
  100. constructor create(const n:string);
  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. is_stab_written : boolean;
  124. {$endif GDB}
  125. constructor create(const n : string);
  126. {$ifdef GDB}
  127. procedure concattypestabto(asmlist : taasmoutput);
  128. {$endif GDB}
  129. end;
  130. tglobalsymtable = class(tabstractunitsymtable)
  131. public
  132. unitsym : tunitsym;
  133. unittypecount : word;
  134. constructor create(const n : string);
  135. destructor destroy;override;
  136. procedure ppuload(ppufile:tcompilerppufile);override;
  137. procedure ppuwrite(ppufile:tcompilerppufile);override;
  138. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  139. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  140. procedure insert(sym : tsymentry);override;
  141. {$ifdef GDB}
  142. function getnewtypecount : word; override;
  143. {$endif}
  144. end;
  145. tstaticsymtable = class(tabstractunitsymtable)
  146. public
  147. constructor create(const n : string);
  148. procedure ppuload(ppufile:tcompilerppufile);override;
  149. procedure ppuwrite(ppufile:tcompilerppufile);override;
  150. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  151. procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
  152. procedure insert(sym : tsymentry);override;
  153. end;
  154. twithsymtable = class(tsymtable)
  155. withrefnode : pointer; { tnode }
  156. constructor create(aowner:tdef;asymsearch:TDictionary;refnode:pointer{tnode});
  157. destructor destroy;override;
  158. procedure clear;override;
  159. end;
  160. tstt_exceptsymtable = class(tsymtable)
  161. public
  162. constructor create;
  163. end;
  164. var
  165. constsymtable : tsymtable; { symtable were the constants can be inserted }
  166. systemunit : tglobalsymtable; { pointer to the system unit }
  167. {****************************************************************************
  168. Functions
  169. ****************************************************************************}
  170. {*** Misc ***}
  171. procedure globaldef(const s : string;var t:ttype);
  172. function findunitsymtable(st:tsymtable):tsymtable;
  173. procedure duplicatesym(sym:tsym);
  174. {*** Search ***}
  175. function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  176. function searchsym_type(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  177. function searchsymonlyin(p : tsymtable;const s : stringid):tsym;
  178. function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
  179. function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
  180. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
  181. function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
  182. function searchsysvar(const s: stringid; var srsym: tvarsym; var symowner: tsymtable): boolean;
  183. function search_class_member(pd : tobjectdef;const s : string):tsym;
  184. {*** Object Helpers ***}
  185. function search_default_property(pd : tobjectdef) : tpropertysym;
  186. {*** symtable stack ***}
  187. procedure RestoreUnitSyms;
  188. {$ifdef DEBUG}
  189. procedure test_symtablestack;
  190. procedure list_symtablestack;
  191. {$endif DEBUG}
  192. {$ifdef UNITALIASES}
  193. type
  194. punit_alias = ^tunit_alias;
  195. tunit_alias = object(TNamedIndexItem)
  196. newname : pstring;
  197. constructor init(const n:string);
  198. destructor done;virtual;
  199. end;
  200. var
  201. unitaliases : pdictionary;
  202. procedure addunitalias(const n:string);
  203. function getunitalias(const n:string):string;
  204. {$endif UNITALIASES}
  205. {*** Init / Done ***}
  206. procedure InitSymtable;
  207. procedure DoneSymtable;
  208. type
  209. toverloaded_operators = array[NOTOKEN..last_overloaded] of tprocsym;
  210. var
  211. overloaded_operators : toverloaded_operators;
  212. { unequal is not equal}
  213. const
  214. overloaded_names : array [NOTOKEN..last_overloaded] of string[16] =
  215. ('error',
  216. 'plus','minus','star','slash','equal',
  217. 'greater','lower','greater_or_equal',
  218. 'lower_or_equal',
  219. 'sym_diff','starstar',
  220. 'as','is','in','or',
  221. 'and','div','mod','not','shl','shr','xor',
  222. 'assign');
  223. implementation
  224. uses
  225. { global }
  226. verbose,globals,
  227. { target }
  228. systems,
  229. { symtable }
  230. symutil,
  231. { module }
  232. fmodule,
  233. {$ifdef GDB}
  234. gdb,
  235. {$endif GDB}
  236. { codegen }
  237. procinfo
  238. ;
  239. {*****************************************************************************
  240. TStoredSymtable
  241. *****************************************************************************}
  242. procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
  243. begin
  244. { load definitions }
  245. loaddefs(ppufile);
  246. { load symbols }
  247. loadsyms(ppufile);
  248. end;
  249. procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile);
  250. begin
  251. { write definitions }
  252. writedefs(ppufile);
  253. { write symbols }
  254. writesyms(ppufile);
  255. end;
  256. procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile);
  257. var
  258. hp : tdef;
  259. b : byte;
  260. begin
  261. { load start of definition section, which holds the amount of defs }
  262. if ppufile.readentry<>ibstartdefs then
  263. Message(unit_f_ppu_read_error);
  264. ppufile.getlongint;
  265. { read definitions }
  266. repeat
  267. b:=ppufile.readentry;
  268. case b of
  269. ibpointerdef : hp:=tpointerdef.ppuload(ppufile);
  270. ibarraydef : hp:=tarraydef.ppuload(ppufile);
  271. iborddef : hp:=torddef.ppuload(ppufile);
  272. ibfloatdef : hp:=tfloatdef.ppuload(ppufile);
  273. ibprocdef : hp:=tprocdef.ppuload(ppufile);
  274. ibshortstringdef : hp:=tstringdef.loadshort(ppufile);
  275. iblongstringdef : hp:=tstringdef.loadlong(ppufile);
  276. ibansistringdef : hp:=tstringdef.loadansi(ppufile);
  277. ibwidestringdef : hp:=tstringdef.loadwide(ppufile);
  278. ibrecorddef : hp:=trecorddef.ppuload(ppufile);
  279. ibobjectdef : hp:=tobjectdef.ppuload(ppufile);
  280. ibenumdef : hp:=tenumdef.ppuload(ppufile);
  281. ibsetdef : hp:=tsetdef.ppuload(ppufile);
  282. ibprocvardef : hp:=tprocvardef.ppuload(ppufile);
  283. ibfiledef : hp:=tfiledef.ppuload(ppufile);
  284. ibclassrefdef : hp:=tclassrefdef.ppuload(ppufile);
  285. ibformaldef : hp:=tformaldef.ppuload(ppufile);
  286. ibvariantdef : hp:=tvariantdef.ppuload(ppufile);
  287. ibenddefs : break;
  288. ibend : Message(unit_f_ppu_read_error);
  289. else
  290. Message1(unit_f_ppu_invalid_entry,tostr(b));
  291. end;
  292. hp.owner:=self;
  293. defindex.insert(hp);
  294. until false;
  295. end;
  296. procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile);
  297. var
  298. b : byte;
  299. sym : tsym;
  300. begin
  301. { load start of definition section, which holds the amount of defs }
  302. if ppufile.readentry<>ibstartsyms then
  303. Message(unit_f_ppu_read_error);
  304. { skip amount of symbols, not used currently }
  305. ppufile.getlongint;
  306. { now read the symbols }
  307. repeat
  308. b:=ppufile.readentry;
  309. case b of
  310. ibtypesym : sym:=ttypesym.ppuload(ppufile);
  311. ibprocsym : sym:=tprocsym.ppuload(ppufile);
  312. ibconstsym : sym:=tconstsym.ppuload(ppufile);
  313. ibvarsym : sym:=tvarsym.ppuload(ppufile);
  314. ibabsolutesym : sym:=tabsolutesym.ppuload(ppufile);
  315. ibenumsym : sym:=tenumsym.ppuload(ppufile);
  316. ibtypedconstsym : sym:=ttypedconstsym.ppuload(ppufile);
  317. ibpropertysym : sym:=tpropertysym.ppuload(ppufile);
  318. ibunitsym : sym:=tunitsym.ppuload(ppufile);
  319. iblabelsym : sym:=tlabelsym.ppuload(ppufile);
  320. ibsyssym : sym:=tsyssym.ppuload(ppufile);
  321. ibrttisym : sym:=trttisym.ppuload(ppufile);
  322. ibendsyms : break;
  323. ibend : Message(unit_f_ppu_read_error);
  324. else
  325. Message1(unit_f_ppu_invalid_entry,tostr(b));
  326. end;
  327. sym.owner:=self;
  328. symindex.insert(sym);
  329. symsearch.insert(sym);
  330. until false;
  331. end;
  332. procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile);
  333. var
  334. pd : tstoreddef;
  335. begin
  336. { each definition get a number, write then the amount of defs to the
  337. ibstartdef entry }
  338. ppufile.putlongint(defindex.count);
  339. ppufile.writeentry(ibstartdefs);
  340. { now write the definition }
  341. pd:=tstoreddef(defindex.first);
  342. while assigned(pd) do
  343. begin
  344. pd.ppuwrite(ppufile);
  345. pd:=tstoreddef(pd.indexnext);
  346. end;
  347. { write end of definitions }
  348. ppufile.writeentry(ibenddefs);
  349. end;
  350. procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile);
  351. var
  352. pd : tstoredsym;
  353. begin
  354. { each definition get a number, write then the amount of syms and the
  355. datasize to the ibsymdef entry }
  356. ppufile.putlongint(symindex.count);
  357. ppufile.writeentry(ibstartsyms);
  358. { foreach is used to write all symbols }
  359. pd:=tstoredsym(symindex.first);
  360. while assigned(pd) do
  361. begin
  362. pd.ppuwrite(ppufile);
  363. pd:=tstoredsym(pd.indexnext);
  364. end;
  365. { end of symbols }
  366. ppufile.writeentry(ibendsyms);
  367. end;
  368. procedure tstoredsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  369. var
  370. b : byte;
  371. d : tderef;
  372. sym : tstoredsym;
  373. prdef : tstoreddef;
  374. begin
  375. b:=ppufile.readentry;
  376. if b <> ibbeginsymtablebrowser then
  377. Message1(unit_f_ppu_invalid_entry,tostr(b));
  378. repeat
  379. b:=ppufile.readentry;
  380. case b of
  381. ibsymref :
  382. begin
  383. ppufile.getderef(d);
  384. sym:=tstoredsym(d.resolve);
  385. if assigned(sym) then
  386. sym.load_references(ppufile,locals);
  387. end;
  388. ibdefref :
  389. begin
  390. ppufile.getderef(d);
  391. prdef:=tstoreddef(d.resolve);
  392. if assigned(prdef) then
  393. begin
  394. if prdef.deftype<>procdef then
  395. Message(unit_f_ppu_read_error);
  396. tprocdef(prdef).load_references(ppufile,locals);
  397. end;
  398. end;
  399. ibendsymtablebrowser :
  400. break;
  401. else
  402. Message1(unit_f_ppu_invalid_entry,tostr(b));
  403. end;
  404. until false;
  405. end;
  406. procedure tstoredsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  407. var
  408. pd : tstoredsym;
  409. begin
  410. ppufile.writeentry(ibbeginsymtablebrowser);
  411. { write all symbols }
  412. pd:=tstoredsym(symindex.first);
  413. while assigned(pd) do
  414. begin
  415. pd.write_references(ppufile,locals);
  416. pd:=tstoredsym(pd.indexnext);
  417. end;
  418. ppufile.writeentry(ibendsymtablebrowser);
  419. end;
  420. procedure tstoredsymtable.deref;
  421. var
  422. hp : tdef;
  423. hs : tsym;
  424. begin
  425. { first deref the interface ttype symbols. This is needs
  426. to be done before the interface defs are derefed, because
  427. the interface defs can contain references to the type symbols
  428. which then already need to contain a resolved restype field (PFV) }
  429. hs:=tsym(symindex.first);
  430. while assigned(hs) do
  431. begin
  432. if hs.typ=typesym then
  433. hs.deref;
  434. hs:=tsym(hs.indexnext);
  435. end;
  436. { deref the interface definitions }
  437. hp:=tdef(defindex.first);
  438. while assigned(hp) do
  439. begin
  440. hp.deref;
  441. hp:=tdef(hp.indexnext);
  442. end;
  443. { deref the interface symbols }
  444. hs:=tsym(symindex.first);
  445. while assigned(hs) do
  446. begin
  447. if hs.typ<>typesym then
  448. hs.deref;
  449. hs:=tsym(hs.indexnext);
  450. end;
  451. end;
  452. procedure tstoredsymtable.derefimpl;
  453. var
  454. hp : tdef;
  455. begin
  456. { deref the implementation part of definitions }
  457. hp:=tdef(defindex.first);
  458. while assigned(hp) do
  459. begin
  460. hp.derefimpl;
  461. hp:=tdef(hp.indexnext);
  462. end;
  463. end;
  464. procedure tstoredsymtable.insert(sym:tsymentry);
  465. var
  466. hsym : tsym;
  467. begin
  468. { set owner and sym indexnb }
  469. sym.owner:=self;
  470. { check the current symtable }
  471. hsym:=tsym(search(sym.name));
  472. if assigned(hsym) then
  473. begin
  474. { in TP and Delphi you can have a local with the
  475. same name as the function, the function is then hidden for
  476. the user. (Under delphi it can still be accessed using result),
  477. but don't allow hiding of RESULT }
  478. if (m_duplicate_names in aktmodeswitches) and
  479. (sym.typ in [varsym,absolutesym]) and
  480. (vo_is_funcret in tvarsym(sym).varoptions) and
  481. not((m_result in aktmodeswitches) and
  482. (vo_is_result in tvarsym(sym).varoptions)) then
  483. sym.name:='hidden'+sym.name
  484. else
  485. begin
  486. DuplicateSym(hsym);
  487. exit;
  488. end;
  489. end;
  490. { register definition of typesym }
  491. if (sym.typ = typesym) and
  492. assigned(ttypesym(sym).restype.def) then
  493. begin
  494. if not(assigned(ttypesym(sym).restype.def.owner)) and
  495. (ttypesym(sym).restype.def.deftype<>errordef) then
  496. registerdef(ttypesym(sym).restype.def);
  497. {$ifdef GDB}
  498. if (cs_debuginfo in aktmoduleswitches) and assigned(debuglist) and
  499. (symtabletype in [globalsymtable,staticsymtable]) then
  500. begin
  501. ttypesym(sym).isusedinstab := true;
  502. {sym.concatstabto(debuglist);}
  503. end;
  504. {$endif GDB}
  505. end;
  506. { insert in index and search hash }
  507. symindex.insert(sym);
  508. symsearch.insert(sym);
  509. end;
  510. function tstoredsymtable.speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;
  511. var
  512. hp : tstoredsym;
  513. newref : tref;
  514. begin
  515. hp:=tstoredsym(inherited speedsearch(s,speedvalue));
  516. if assigned(hp) then
  517. begin
  518. { reject non static members in static procedures }
  519. if (symtabletype=objectsymtable) and
  520. not(sp_static in hp.symoptions) and
  521. allow_only_static then
  522. Message(sym_e_only_static_in_static);
  523. { unit uses count }
  524. if (unitid<>0) and
  525. (symtabletype = globalsymtable) and
  526. assigned(tglobalsymtable(self).unitsym) then
  527. inc(tglobalsymtable(self).unitsym.refs);
  528. {$ifdef GDB}
  529. { if it is a type, we need the stabs of this type
  530. this might be the cause of the class debug problems
  531. as TCHILDCLASS.Create did not generate appropriate
  532. stabs debug info if TCHILDCLASS wasn't used anywhere else PM }
  533. if (cs_debuginfo in aktmoduleswitches) and
  534. (hp.typ=typesym) and
  535. make_ref then
  536. begin
  537. if assigned(ttypesym(hp).restype.def) then
  538. tstoreddef(ttypesym(hp).restype.def).numberstring
  539. else
  540. ttypesym(hp).isusedinstab:=true;
  541. end;
  542. {$endif GDB}
  543. { unitsym are only loaded for browsing PM }
  544. { this was buggy anyway because we could use }
  545. { unitsyms from other units in _USES !! }
  546. {if (symtabletype=unitsymtable) and (hp.typ=unitsym) and
  547. assigned(current_module) and (current_module.globalsymtable<>.load) then
  548. hp:=nil;}
  549. if make_ref and (cs_browser in aktmoduleswitches) then
  550. begin
  551. newref:=tref.create(hp.lastref,@akttokenpos);
  552. { for symbols that are in tables without browser info or syssyms }
  553. if hp.refcount=0 then
  554. begin
  555. hp.defref:=newref;
  556. hp.lastref:=newref;
  557. end
  558. else
  559. if resolving_forward and assigned(hp.defref) then
  560. { put it as second reference }
  561. begin
  562. newref.nextref:=hp.defref.nextref;
  563. hp.defref.nextref:=newref;
  564. hp.lastref.nextref:=nil;
  565. end
  566. else
  567. hp.lastref:=newref;
  568. inc(hp.refcount);
  569. end;
  570. if make_ref then
  571. inc(hp.refs);
  572. end; { value was not found }
  573. speedsearch:=hp;
  574. end;
  575. {**************************************
  576. Callbacks
  577. **************************************}
  578. procedure TStoredSymtable.check_forward(sym : TNamedIndexItem;arg:pointer);
  579. begin
  580. if tsym(sym).typ=procsym then
  581. tprocsym(sym).check_forward
  582. { check also object method table }
  583. { we needn't to test the def list }
  584. { because each object has to have a type sym }
  585. else
  586. if (tsym(sym).typ=typesym) and
  587. assigned(ttypesym(sym).restype.def) and
  588. (ttypesym(sym).restype.def.deftype=objectdef) then
  589. tobjectdef(ttypesym(sym).restype.def).check_forwards;
  590. end;
  591. procedure TStoredSymtable.labeldefined(p : TNamedIndexItem;arg:pointer);
  592. begin
  593. if (tsym(p).typ=labelsym) and
  594. not(tlabelsym(p).defined) then
  595. begin
  596. if tlabelsym(p).used then
  597. Message1(sym_e_label_used_and_not_defined,tlabelsym(p).realname)
  598. else
  599. Message1(sym_w_label_not_defined,tlabelsym(p).realname);
  600. end;
  601. end;
  602. procedure TStoredSymtable.unitsymbolused(p : TNamedIndexItem;arg:pointer);
  603. begin
  604. if (tsym(p).typ=unitsym) and
  605. (tunitsym(p).refs=0) and
  606. { do not claim for unit name itself !! }
  607. assigned(tunitsym(p).unitsymtable) and
  608. (tunitsym(p).unitsymtable.symtabletype=globalsymtable) then
  609. MessagePos2(tsym(p).fileinfo,sym_n_unit_not_used,p.name,current_module.modulename^);
  610. end;
  611. procedure TStoredSymtable.varsymbolused(p : TNamedIndexItem;arg:pointer);
  612. begin
  613. if (tsym(p).typ=varsym) and
  614. ((tsym(p).owner.symtabletype in
  615. [parasymtable,localsymtable,objectsymtable,staticsymtable])) then
  616. begin
  617. { unused symbol should be reported only if no }
  618. { error is reported }
  619. { if the symbol is in a register it is used }
  620. { also don't count the value parameters which have local copies }
  621. { also don't claim for high param of open parameters (PM) }
  622. if (Errorcount<>0) or
  623. (assigned(tvarsym(p).paraitem) and
  624. tvarsym(p).paraitem.is_hidden) then
  625. exit;
  626. if (tvarsym(p).refs=0) then
  627. begin
  628. if (vo_is_funcret in tvarsym(p).varoptions) then
  629. begin
  630. { don't warn about the result of constructors }
  631. if (tsym(p).owner.symtabletype<>localsymtable) or
  632. (tprocdef(tsym(p).owner.defowner).proctypeoption<>potype_constructor) then
  633. MessagePos(tsym(p).fileinfo,sym_w_function_result_not_set)
  634. end
  635. else if (tsym(p).owner.symtabletype=parasymtable) then
  636. MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_not_used,tsym(p).realname)
  637. else if (tsym(p).owner.symtabletype=objectsymtable) then
  638. MessagePos2(tsym(p).fileinfo,sym_n_private_identifier_not_used,tsym(p).owner.realname^,tsym(p).realname)
  639. else
  640. MessagePos1(tsym(p).fileinfo,sym_n_local_identifier_not_used,tsym(p).realname);
  641. end
  642. else if tvarsym(p).varstate=vs_assigned then
  643. begin
  644. if (tsym(p).owner.symtabletype=parasymtable) then
  645. begin
  646. if not(tvarsym(p).varspez in [vs_var,vs_out]) and
  647. not(vo_is_funcret in tvarsym(p).varoptions) then
  648. MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_only_set,tsym(p).realname)
  649. end
  650. else if (tsym(p).owner.symtabletype=objectsymtable) then
  651. MessagePos2(tsym(p).fileinfo,sym_n_private_identifier_only_set,tsym(p).owner.realname^,tsym(p).realname)
  652. else if not(vo_is_exported in tvarsym(p).varoptions) and
  653. not(vo_is_funcret in tvarsym(p).varoptions) then
  654. MessagePos1(tsym(p).fileinfo,sym_n_local_identifier_only_set,tsym(p).realname);
  655. end;
  656. end
  657. else if ((tsym(p).owner.symtabletype in
  658. [objectsymtable,parasymtable,localsymtable,staticsymtable])) then
  659. begin
  660. if (Errorcount<>0) or
  661. (copy(p.name,1,3)='def') then
  662. exit;
  663. { do not claim for inherited private fields !! }
  664. if (tstoredsym(p).refs=0) and (tsym(p).owner.symtabletype=objectsymtable) then
  665. MessagePos2(tsym(p).fileinfo,sym_n_private_method_not_used,tsym(p).owner.realname^,tsym(p).realname)
  666. { units references are problematic }
  667. else
  668. begin
  669. if (tstoredsym(p).refs=0) and
  670. not(tsym(p).typ in [enumsym,unitsym]) and
  671. not(is_funcret_sym(tsym(p))) and
  672. (
  673. (tsym(p).typ<>procsym) or
  674. {$ifdef GDB}
  675. not (tprocsym(p).is_global) or
  676. {$endif GDB}
  677. { all program functions are declared global
  678. but unused should still be signaled PM }
  679. ((tsym(p).owner.symtabletype=staticsymtable) and
  680. not current_module.is_unit)
  681. ) then
  682. MessagePos2(tsym(p).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(p).typ],tsym(p).realname);
  683. end;
  684. end;
  685. end;
  686. procedure TStoredSymtable.TestPrivate(p : TNamedIndexItem;arg:pointer);
  687. begin
  688. if sp_private in tsym(p).symoptions then
  689. varsymbolused(p,arg);
  690. end;
  691. procedure TStoredSymtable.objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
  692. begin
  693. {
  694. Don't test simple object aliases PM
  695. }
  696. if (tsym(p).typ=typesym) and
  697. (ttypesym(p).restype.def.deftype=objectdef) and
  698. (ttypesym(p).restype.def.typesym=tsym(p)) then
  699. tobjectdef(ttypesym(p).restype.def).symtable.foreach({$ifdef FPCPROCVAR}@{$endif}TestPrivate,nil);
  700. end;
  701. procedure tstoredsymtable.unchain_overloads(p : TNamedIndexItem;arg:pointer);
  702. begin
  703. if tsym(p).typ=procsym then
  704. tprocsym(p).unchain_overload;
  705. end;
  706. {$ifdef GDB}
  707. procedure TStoredSymtable.concatstab(p : TNamedIndexItem;arg:pointer);
  708. begin
  709. if tsym(p).typ <> procsym then
  710. tstoredsym(p).concatstabto(TAAsmOutput(arg));
  711. end;
  712. procedure TStoredSymtable.resetstab(p : TNamedIndexItem;arg:pointer);
  713. begin
  714. if tsym(p).typ <> procsym then
  715. tstoredsym(p).isstabwritten:=false;
  716. end;
  717. procedure TStoredSymtable.concattypestab(p : TNamedIndexItem;arg:pointer);
  718. begin
  719. if tsym(p).typ = typesym then
  720. begin
  721. tstoredsym(p).isstabwritten:=false;
  722. tstoredsym(p).concatstabto(TAAsmOutput(arg));
  723. end;
  724. end;
  725. function tstoredsymtable.getnewtypecount : word;
  726. begin
  727. getnewtypecount:=pglobaltypecount^;
  728. inc(pglobaltypecount^);
  729. end;
  730. {$endif GDB}
  731. procedure tstoredsymtable.chainoperators;
  732. var
  733. t : ttoken;
  734. srsym : tsym;
  735. srsymtable,
  736. storesymtablestack : tsymtable;
  737. begin
  738. storesymtablestack:=symtablestack;
  739. symtablestack:=self;
  740. make_ref:=false;
  741. for t:=first_overloaded to last_overloaded do
  742. begin
  743. overloaded_operators[t]:=nil;
  744. { each operator has a unique lowercased internal name PM }
  745. while assigned(symtablestack) do
  746. begin
  747. searchsym(overloaded_names[t],srsym,srsymtable);
  748. if not assigned(srsym) then
  749. begin
  750. if (t=_STARSTAR) then
  751. begin
  752. symtablestack:=systemunit;
  753. searchsym('POWER',srsym,srsymtable);
  754. end;
  755. end;
  756. if assigned(srsym) then
  757. begin
  758. if (srsym.typ<>procsym) then
  759. internalerror(12344321);
  760. { remove all previous chains }
  761. tprocsym(srsym).unchain_overload;
  762. { use this procsym as start ? }
  763. if not assigned(overloaded_operators[t]) then
  764. overloaded_operators[t]:=tprocsym(srsym)
  765. else
  766. { already got a procsym, only add defs defined in the
  767. unit of the current procsym }
  768. Tprocsym(srsym).concat_procdefs_to(overloaded_operators[t]);
  769. symtablestack:=srsym.owner.next;
  770. end
  771. else
  772. begin
  773. symtablestack:=nil;
  774. end;
  775. { search for same procsym in other units }
  776. end;
  777. symtablestack:=self;
  778. end;
  779. make_ref:=true;
  780. symtablestack:=storesymtablestack;
  781. end;
  782. {***********************************************
  783. Process all entries
  784. ***********************************************}
  785. { checks, if all procsyms and methods are defined }
  786. procedure tstoredsymtable.check_forwards;
  787. begin
  788. foreach({$ifdef FPCPROCVAR}@{$endif}check_forward,nil);
  789. end;
  790. procedure tstoredsymtable.checklabels;
  791. begin
  792. foreach({$ifdef FPCPROCVAR}@{$endif}labeldefined,nil);
  793. end;
  794. procedure tstoredsymtable.allunitsused;
  795. begin
  796. foreach({$ifdef FPCPROCVAR}@{$endif}unitsymbolused,nil);
  797. end;
  798. procedure tstoredsymtable.allsymbolsused;
  799. begin
  800. foreach({$ifdef FPCPROCVAR}@{$endif}varsymbolused,nil);
  801. end;
  802. procedure tstoredsymtable.allprivatesused;
  803. begin
  804. foreach({$ifdef FPCPROCVAR}@{$endif}objectprivatesymbolused,nil);
  805. end;
  806. procedure tstoredsymtable.unchain_overloaded;
  807. begin
  808. foreach({$ifdef FPCPROCVAR}@{$endif}unchain_overloads,nil);
  809. end;
  810. {$ifdef GDB}
  811. procedure tstoredsymtable.concatstabto(asmlist : taasmoutput);
  812. begin
  813. if symtabletype in [inlineparasymtable,inlinelocalsymtable] then
  814. foreach({$ifdef FPCPROCVAR}@{$endif}resetstab,nil);
  815. foreach({$ifdef FPCPROCVAR}@{$endif}concatstab,asmlist);
  816. end;
  817. {$endif}
  818. procedure TStoredSymtable._needs_init_final(p : tnamedindexitem;arg:pointer);
  819. begin
  820. if b_needs_init_final then
  821. exit;
  822. case tsym(p).typ of
  823. varsym :
  824. begin
  825. if not(is_class(tvarsym(p).vartype.def)) and
  826. tstoreddef(tvarsym(p).vartype.def).needs_inittable then
  827. b_needs_init_final:=true;
  828. end;
  829. typedconstsym :
  830. begin
  831. if ttypedconstsym(p).is_writable and
  832. tstoreddef(ttypedconstsym(p).typedconsttype.def).needs_inittable then
  833. b_needs_init_final:=true;
  834. end;
  835. end;
  836. end;
  837. { returns true, if p contains data which needs init/final code }
  838. function tstoredsymtable.needs_init_final : boolean;
  839. begin
  840. b_needs_init_final:=false;
  841. foreach({$ifdef FPCPROCVAR}@{$endif}_needs_init_final,nil);
  842. needs_init_final:=b_needs_init_final;
  843. end;
  844. {****************************************************************************
  845. TAbstractRecordSymtable
  846. ****************************************************************************}
  847. constructor tabstractrecordsymtable.create(const n:string);
  848. begin
  849. inherited create(n);
  850. datasize:=0;
  851. dataalignment:=1;
  852. end;
  853. procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile);
  854. var
  855. storesymtable : tsymtable;
  856. begin
  857. storesymtable:=aktrecordsymtable;
  858. aktrecordsymtable:=self;
  859. inherited ppuload(ppufile);
  860. aktrecordsymtable:=storesymtable;
  861. end;
  862. procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile);
  863. var
  864. oldtyp : byte;
  865. storesymtable : tsymtable;
  866. begin
  867. storesymtable:=aktrecordsymtable;
  868. aktrecordsymtable:=self;
  869. oldtyp:=ppufile.entrytyp;
  870. ppufile.entrytyp:=subentryid;
  871. inherited ppuwrite(ppufile);
  872. ppufile.entrytyp:=oldtyp;
  873. aktrecordsymtable:=storesymtable;
  874. end;
  875. procedure tabstractrecordsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  876. var
  877. storesymtable : tsymtable;
  878. begin
  879. storesymtable:=aktrecordsymtable;
  880. aktrecordsymtable:=self;
  881. inherited load_references(ppufile,locals);
  882. aktrecordsymtable:=storesymtable;
  883. end;
  884. procedure tabstractrecordsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  885. var
  886. storesymtable : tsymtable;
  887. begin
  888. storesymtable:=aktrecordsymtable;
  889. aktrecordsymtable:=self;
  890. inherited write_references(ppufile,locals);
  891. aktrecordsymtable:=storesymtable;
  892. end;
  893. procedure tabstractrecordsymtable.insertfield(sym : tvarsym;addsym:boolean);
  894. var
  895. l,varalign : longint;
  896. vardef : tdef;
  897. begin
  898. if addsym then
  899. insert(sym);
  900. { Calculate field offset }
  901. l:=tvarsym(sym).getvaluesize;
  902. vardef:=tvarsym(sym).vartype.def;
  903. { this symbol can't be loaded to a register }
  904. exclude(tvarsym(sym).varoptions,vo_regable);
  905. exclude(tvarsym(sym).varoptions,vo_fpuregable);
  906. { get the alignment size }
  907. if (aktalignment.recordalignmax=-1) then
  908. begin
  909. varalign:=vardef.alignment;
  910. if (varalign>4) and
  911. ((varalign mod 4)<>0) and
  912. (vardef.deftype=arraydef) then
  913. Message1(sym_w_wrong_C_pack,vardef.typename);
  914. if varalign=0 then
  915. varalign:=l;
  916. if (dataalignment<aktalignment.maxCrecordalign) then
  917. begin
  918. if (varalign>16) and (dataalignment<32) then
  919. dataalignment:=32
  920. else if (varalign>12) and (dataalignment<16) then
  921. dataalignment:=16
  922. { 12 is needed for long double }
  923. else if (varalign>8) and (dataalignment<12) then
  924. dataalignment:=12
  925. else if (varalign>4) and (dataalignment<8) then
  926. dataalignment:=8
  927. else if (varalign>2) and (dataalignment<4) then
  928. dataalignment:=4
  929. else if (varalign>1) and (dataalignment<2) then
  930. dataalignment:=2;
  931. end;
  932. dataalignment:=min(dataalignment,aktalignment.maxCrecordalign);
  933. end
  934. else
  935. varalign:=vardef.alignment;
  936. if varalign=0 then
  937. varalign:=size_2_align(l);
  938. varalign:=used_align(varalign,aktalignment.recordalignmin,dataalignment);
  939. tvarsym(sym).fieldoffset:=align(datasize,varalign);
  940. datasize:=tvarsym(sym).fieldoffset+l;
  941. end;
  942. {****************************************************************************
  943. TRecordSymtable
  944. ****************************************************************************}
  945. constructor trecordsymtable.create;
  946. begin
  947. inherited create('');
  948. symtabletype:=recordsymtable;
  949. end;
  950. { this procedure is reserved for inserting case variant into
  951. a record symtable }
  952. { the offset is the location of the start of the variant
  953. and datasize and dataalignment corresponds to
  954. the complete size (see code in pdecl unit) PM }
  955. procedure trecordsymtable.insert_in(tsymt : trecordsymtable;offset : longint);
  956. var
  957. ps,nps : tvarsym;
  958. pd,npd : tdef;
  959. storesize,storealign : longint;
  960. begin
  961. storesize:=tsymt.datasize;
  962. storealign:=tsymt.dataalignment;
  963. tsymt.datasize:=offset;
  964. ps:=tvarsym(symindex.first);
  965. while assigned(ps) do
  966. begin
  967. nps:=tvarsym(ps.indexnext);
  968. { remove from current symtable }
  969. symindex.deleteindex(ps);
  970. ps.left:=nil;
  971. ps.right:=nil;
  972. { add to symt }
  973. ps.owner:=tsymt;
  974. tsymt.datasize:=ps.fieldoffset+offset;
  975. tsymt.symindex.insert(ps);
  976. tsymt.symsearch.insert(ps);
  977. { update address }
  978. ps.fieldoffset:=tsymt.datasize;
  979. { next }
  980. ps:=nps;
  981. end;
  982. pd:=tdef(defindex.first);
  983. while assigned(pd) do
  984. begin
  985. npd:=tdef(pd.indexnext);
  986. defindex.deleteindex(pd);
  987. pd.left:=nil;
  988. pd.right:=nil;
  989. tsymt.registerdef(pd);
  990. pd:=npd;
  991. end;
  992. tsymt.datasize:=storesize;
  993. tsymt.dataalignment:=storealign;
  994. end;
  995. {****************************************************************************
  996. TObjectSymtable
  997. ****************************************************************************}
  998. constructor tobjectsymtable.create(const n:string);
  999. begin
  1000. inherited create(n);
  1001. symtabletype:=objectsymtable;
  1002. end;
  1003. procedure tobjectsymtable.insert(sym:tsymentry);
  1004. var
  1005. hsym : tsym;
  1006. begin
  1007. { check for duplicate field id in inherited classes }
  1008. if (sym.typ=varsym) and
  1009. assigned(defowner) and
  1010. (
  1011. not(m_delphi in aktmodeswitches) or
  1012. is_object(tdef(defowner))
  1013. ) then
  1014. begin
  1015. { but private ids can be reused }
  1016. hsym:=search_class_member(tobjectdef(defowner),sym.name);
  1017. if assigned(hsym) and
  1018. tstoredsym(hsym).is_visible_for_object(tobjectdef(defowner)) then
  1019. begin
  1020. DuplicateSym(hsym);
  1021. exit;
  1022. end;
  1023. end;
  1024. inherited insert(sym);
  1025. end;
  1026. {****************************************************************************
  1027. TAbstractLocalSymtable
  1028. ****************************************************************************}
  1029. procedure tabstractlocalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1030. var
  1031. oldtyp : byte;
  1032. begin
  1033. oldtyp:=ppufile.entrytyp;
  1034. ppufile.entrytyp:=subentryid;
  1035. { write definitions }
  1036. writedefs(ppufile);
  1037. { write symbols }
  1038. writesyms(ppufile);
  1039. ppufile.entrytyp:=oldtyp;
  1040. end;
  1041. {****************************************************************************
  1042. TLocalSymtable
  1043. ****************************************************************************}
  1044. constructor tlocalsymtable.create(level:byte);
  1045. begin
  1046. inherited create('');
  1047. symtabletype:=localsymtable;
  1048. symtablelevel:=level;
  1049. end;
  1050. procedure tlocalsymtable.insert(sym:tsymentry);
  1051. var
  1052. hsym : tsym;
  1053. begin
  1054. { need to hide function result? }
  1055. hsym:=tsym(search(sym.name));
  1056. if assigned(hsym) then
  1057. begin
  1058. { a local and the function can have the same
  1059. name in TP and Delphi, but RESULT not }
  1060. if (m_duplicate_names in aktmodeswitches) and
  1061. (hsym.typ in [absolutesym,varsym]) and
  1062. (vo_is_funcret in tvarsym(hsym).varoptions) and
  1063. not((m_result in aktmodeswitches) and
  1064. (vo_is_result in tvarsym(hsym).varoptions)) then
  1065. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1066. else
  1067. begin
  1068. DuplicateSym(hsym);
  1069. exit;
  1070. end;
  1071. end;
  1072. if assigned(next) and
  1073. (next.symtabletype=parasymtable) then
  1074. begin
  1075. { check para symtable }
  1076. hsym:=tsym(next.search(sym.name));
  1077. if assigned(hsym) then
  1078. begin
  1079. { a local and the function can have the same
  1080. name in TP and Delphi, but RESULT not }
  1081. if (m_duplicate_names in aktmodeswitches) and
  1082. (sym.typ in [absolutesym,varsym]) and
  1083. (vo_is_funcret in tvarsym(sym).varoptions) and
  1084. not((m_result in aktmodeswitches) and
  1085. (vo_is_result in tvarsym(sym).varoptions)) then
  1086. sym.name:='hidden'+sym.name
  1087. else
  1088. begin
  1089. DuplicateSym(hsym);
  1090. exit;
  1091. end;
  1092. end;
  1093. { check for duplicate id in local symtable of methods }
  1094. if assigned(next.next) and
  1095. { funcretsym is allowed !! }
  1096. (not is_funcret_sym(sym)) and
  1097. (next.next.symtabletype=objectsymtable) then
  1098. begin
  1099. hsym:=search_class_member(tobjectdef(next.next.defowner),sym.name);
  1100. if assigned(hsym) and
  1101. { private ids can be reused }
  1102. (not(sp_private in hsym.symoptions) or
  1103. (hsym.owner.defowner.owner.symtabletype<>globalsymtable)) then
  1104. begin
  1105. { delphi allows to reuse the names in a class, but not
  1106. in object (tp7 compatible) }
  1107. if not((m_delphi in aktmodeswitches) and
  1108. is_class(tdef(next.next.defowner))) then
  1109. begin
  1110. DuplicateSym(hsym);
  1111. exit;
  1112. end;
  1113. end;
  1114. end;
  1115. end;
  1116. inherited insert(sym);
  1117. end;
  1118. {****************************************************************************
  1119. TParaSymtable
  1120. ****************************************************************************}
  1121. constructor tparasymtable.create(level:byte);
  1122. begin
  1123. inherited create('');
  1124. symtabletype:=parasymtable;
  1125. symtablelevel:=level;
  1126. end;
  1127. procedure tparasymtable.insert(sym:tsymentry);
  1128. var
  1129. hsym : tsym;
  1130. begin
  1131. { check for duplicate id in para symtable of methods }
  1132. if assigned(next) and
  1133. (next.symtabletype=objectsymtable) and
  1134. { funcretsym is allowed }
  1135. (not is_funcret_sym(sym)) then
  1136. begin
  1137. hsym:=search_class_member(tobjectdef(next.defowner),sym.name);
  1138. { private ids can be reused }
  1139. if assigned(hsym) and
  1140. tstoredsym(hsym).is_visible_for_object(tobjectdef(next.defowner)) then
  1141. begin
  1142. { delphi allows to reuse the names in a class, but not
  1143. in object (tp7 compatible) }
  1144. if not((m_delphi in aktmodeswitches) and
  1145. is_class_or_interface(tobjectdef(next.defowner))) then
  1146. begin
  1147. DuplicateSym(hsym);
  1148. exit;
  1149. end;
  1150. end;
  1151. end;
  1152. inherited insert(sym);
  1153. end;
  1154. {****************************************************************************
  1155. TAbstractUnitSymtable
  1156. ****************************************************************************}
  1157. constructor tabstractunitsymtable.create(const n : string);
  1158. begin
  1159. inherited create(n);
  1160. symsearch.usehash;
  1161. {$ifdef GDB}
  1162. { reset GDB things }
  1163. prev_dbx_counter := dbx_counter;
  1164. dbx_counter := nil;
  1165. is_stab_written:=false;
  1166. dbx_count := -1;
  1167. {$endif GDB}
  1168. end;
  1169. {$ifdef GDB}
  1170. procedure tabstractunitsymtable.concattypestabto(asmlist : taasmoutput);
  1171. var prev_dbx_count : plongint;
  1172. begin
  1173. if is_stab_written then
  1174. exit;
  1175. if not assigned(name) then
  1176. name := stringdup('Main_program');
  1177. if (symtabletype = globalsymtable) and
  1178. (current_module.globalsymtable<>self) then
  1179. begin
  1180. unitid:=current_module.unitcount;
  1181. inc(current_module.unitcount);
  1182. end;
  1183. asmList.concat(tai_comment.Create(strpnew('Begin unit '+name^+' has index '+tostr(unitid))));
  1184. if cs_gdb_dbx in aktglobalswitches then
  1185. begin
  1186. if dbx_count_ok then
  1187. begin
  1188. asmList.concat(tai_comment.Create(strpnew('"repeated" unit '+name^
  1189. +' has index '+tostr(unitid)+' dbx count = '+tostr(dbx_count))));
  1190. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1191. +tostr(N_EXCL)+',0,0,'+tostr(dbx_count))));
  1192. exit;
  1193. end
  1194. else if (current_module.globalsymtable<>self) then
  1195. begin
  1196. prev_dbx_count := dbx_counter;
  1197. dbx_counter := nil;
  1198. do_count_dbx:=false;
  1199. if (symtabletype = globalsymtable) and (unitid<>0) then
  1200. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
  1201. dbx_counter := @dbx_count;
  1202. dbx_count:=0;
  1203. do_count_dbx:=assigned(dbx_counter);
  1204. end;
  1205. end;
  1206. foreach({$ifdef FPCPROCVAR}@{$endif}concattypestab,asmlist);
  1207. if cs_gdb_dbx in aktglobalswitches then
  1208. begin
  1209. if (current_module.globalsymtable<>self) then
  1210. begin
  1211. dbx_counter := prev_dbx_count;
  1212. do_count_dbx:=false;
  1213. asmList.concat(tai_comment.Create(strpnew('End unit '+name^
  1214. +' has index '+tostr(unitid))));
  1215. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1216. +tostr(N_EINCL)+',0,0,0')));
  1217. do_count_dbx:=assigned(dbx_counter);
  1218. dbx_count_ok := {true}false;
  1219. end;
  1220. end;
  1221. is_stab_written:=true;
  1222. end;
  1223. {$endif GDB}
  1224. {****************************************************************************
  1225. TStaticSymtable
  1226. ****************************************************************************}
  1227. constructor tstaticsymtable.create(const n : string);
  1228. begin
  1229. inherited create(n);
  1230. symtabletype:=staticsymtable;
  1231. symtablelevel:=main_program_level;
  1232. end;
  1233. procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile);
  1234. begin
  1235. aktstaticsymtable:=self;
  1236. next:=symtablestack;
  1237. symtablestack:=self;
  1238. inherited ppuload(ppufile);
  1239. { now we can deref the syms and defs }
  1240. deref;
  1241. { restore symtablestack }
  1242. symtablestack:=next;
  1243. end;
  1244. procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile);
  1245. begin
  1246. aktstaticsymtable:=self;
  1247. inherited ppuwrite(ppufile);
  1248. end;
  1249. procedure tstaticsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  1250. begin
  1251. aktstaticsymtable:=self;
  1252. inherited load_references(ppufile,locals);
  1253. end;
  1254. procedure tstaticsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  1255. begin
  1256. aktstaticsymtable:=self;
  1257. inherited write_references(ppufile,locals);
  1258. end;
  1259. procedure tstaticsymtable.insert(sym:tsymentry);
  1260. var
  1261. hsym : tsym;
  1262. begin
  1263. { also check the global symtable }
  1264. if assigned(next) and
  1265. (next.unitid=0) then
  1266. begin
  1267. hsym:=tsym(next.search(sym.name));
  1268. if assigned(hsym) then
  1269. begin
  1270. { Delphi you can have a symbol with the same name as the
  1271. unit, the unit can then not be accessed anymore using
  1272. <unit>.<id>, so we can hide the symbol }
  1273. if (m_duplicate_names in aktmodeswitches) and
  1274. (hsym.typ=symconst.unitsym) then
  1275. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1276. else
  1277. begin
  1278. DuplicateSym(hsym);
  1279. exit;
  1280. end;
  1281. end;
  1282. end;
  1283. inherited insert(sym);
  1284. end;
  1285. {****************************************************************************
  1286. TGlobalSymtable
  1287. ****************************************************************************}
  1288. constructor tglobalsymtable.create(const n : string);
  1289. begin
  1290. inherited create(n);
  1291. symtabletype:=globalsymtable;
  1292. symtablelevel:=main_program_level;
  1293. unitid:=0;
  1294. unitsym:=nil;
  1295. {$ifdef GDB}
  1296. if cs_gdb_dbx in aktglobalswitches then
  1297. begin
  1298. dbx_count := 0;
  1299. unittypecount:=1;
  1300. pglobaltypecount := @unittypecount;
  1301. {unitid:=current_module.unitcount;}
  1302. debugList.concat(tai_comment.Create(strpnew('Global '+name^+' has index '+tostr(unitid))));
  1303. debugList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
  1304. {inc(current_module.unitcount);}
  1305. { we can't use dbx_vcount, because we don't know
  1306. if the object file will be loaded before or afeter PM }
  1307. dbx_count_ok:=false;
  1308. dbx_counter:=@dbx_count;
  1309. do_count_dbx:=true;
  1310. end;
  1311. {$endif GDB}
  1312. end;
  1313. destructor tglobalsymtable.destroy;
  1314. var
  1315. pus : tunitsym;
  1316. begin
  1317. pus:=unitsym;
  1318. while assigned(pus) do
  1319. begin
  1320. unitsym:=pus.prevsym;
  1321. pus.prevsym:=nil;
  1322. pus.unitsymtable:=nil;
  1323. pus:=unitsym;
  1324. end;
  1325. inherited destroy;
  1326. end;
  1327. procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile);
  1328. {$ifdef GDB}
  1329. var
  1330. b : byte;
  1331. {$endif GDB}
  1332. begin
  1333. {$ifdef GDB}
  1334. if cs_gdb_dbx in aktglobalswitches then
  1335. begin
  1336. UnitTypeCount:=1;
  1337. PglobalTypeCount:=@UnitTypeCount;
  1338. end;
  1339. {$endif GDB}
  1340. aktglobalsymtable:=self;
  1341. next:=symtablestack;
  1342. symtablestack:=self;
  1343. inherited ppuload(ppufile);
  1344. { now we can deref the syms and defs }
  1345. deref;
  1346. { restore symtablestack }
  1347. symtablestack:=next;
  1348. { read dbx count }
  1349. {$ifdef GDB}
  1350. if (current_module.flags and uf_has_dbx)<>0 then
  1351. begin
  1352. b:=ppufile.readentry;
  1353. if b<>ibdbxcount then
  1354. Message(unit_f_ppu_dbx_count_problem)
  1355. else
  1356. dbx_count:=ppufile.getlongint;
  1357. {$IfDef EXTDEBUG}
  1358. writeln('Read dbx_count ',dbx_count,' in unit ',name^,'.ppu');
  1359. {$ENDIF EXTDEBUG}
  1360. { we can't use dbx_vcount, because we don't know
  1361. if the object file will be loaded before or afeter PM }
  1362. dbx_count_ok := {true}false;
  1363. end
  1364. else
  1365. begin
  1366. dbx_count:=-1;
  1367. dbx_count_ok:=false;
  1368. end;
  1369. {$endif GDB}
  1370. end;
  1371. procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile);
  1372. begin
  1373. aktglobalsymtable:=self;
  1374. { write the symtable entries }
  1375. inherited ppuwrite(ppufile);
  1376. { write dbx count }
  1377. {$ifdef GDB}
  1378. if cs_gdb_dbx in aktglobalswitches then
  1379. begin
  1380. {$IfDef EXTDEBUG}
  1381. writeln('Writing dbx_count ',dbx_count,' in unit ',name^,'.ppu');
  1382. {$ENDIF EXTDEBUG}
  1383. ppufile.do_crc:=false;
  1384. ppufile.putlongint(dbx_count);
  1385. ppufile.writeentry(ibdbxcount);
  1386. ppufile.do_crc:=true;
  1387. end;
  1388. {$endif GDB}
  1389. end;
  1390. procedure tglobalsymtable.load_references(ppufile:tcompilerppufile;locals:boolean);
  1391. begin
  1392. aktglobalsymtable:=self;
  1393. inherited load_references(ppufile,locals);
  1394. end;
  1395. procedure tglobalsymtable.write_references(ppufile:tcompilerppufile;locals:boolean);
  1396. begin
  1397. aktglobalsymtable:=self;
  1398. inherited write_references(ppufile,locals);
  1399. end;
  1400. procedure tglobalsymtable.insert(sym:tsymentry);
  1401. var
  1402. hsym : tsym;
  1403. begin
  1404. { also check the global symtable }
  1405. if assigned(next) and
  1406. (next.unitid=0) then
  1407. begin
  1408. hsym:=tsym(next.search(sym.name));
  1409. if assigned(hsym) then
  1410. begin
  1411. { Delphi you can have a symbol with the same name as the
  1412. unit, the unit can then not be accessed anymore using
  1413. <unit>.<id>, so we can hide the symbol }
  1414. if (m_duplicate_names in aktmodeswitches) and
  1415. (hsym.typ=symconst.unitsym) then
  1416. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1417. else
  1418. begin
  1419. DuplicateSym(hsym);
  1420. exit;
  1421. end;
  1422. end;
  1423. end;
  1424. hsym:=tsym(search(sym.name));
  1425. if assigned(hsym) then
  1426. begin
  1427. { Delphi you can have a symbol with the same name as the
  1428. unit, the unit can then not be accessed anymore using
  1429. <unit>.<id>, so we can hide the symbol }
  1430. if (m_duplicate_names in aktmodeswitches) and
  1431. (hsym.typ=symconst.unitsym) then
  1432. hsym.owner.rename(hsym.name,'hidden'+hsym.name)
  1433. else
  1434. begin
  1435. DuplicateSym(hsym);
  1436. exit;
  1437. end;
  1438. end;
  1439. inherited insert(sym);
  1440. end;
  1441. {$ifdef GDB}
  1442. function tglobalsymtable.getnewtypecount : word;
  1443. begin
  1444. if not (cs_gdb_dbx in aktglobalswitches) then
  1445. getnewtypecount:=inherited getnewtypecount
  1446. else
  1447. begin
  1448. getnewtypecount:=unittypecount;
  1449. inc(unittypecount);
  1450. end;
  1451. end;
  1452. {$endif}
  1453. {****************************************************************************
  1454. TWITHSYMTABLE
  1455. ****************************************************************************}
  1456. constructor twithsymtable.create(aowner:tdef;asymsearch:TDictionary;refnode:pointer{tnode});
  1457. begin
  1458. inherited create('');
  1459. symtabletype:=withsymtable;
  1460. withrefnode:=refnode;
  1461. { we don't need the symsearch }
  1462. symsearch.free;
  1463. { set the defaults }
  1464. symsearch:=asymsearch;
  1465. defowner:=aowner;
  1466. end;
  1467. destructor twithsymtable.destroy;
  1468. begin
  1469. symsearch:=nil;
  1470. inherited destroy;
  1471. end;
  1472. procedure twithsymtable.clear;
  1473. begin
  1474. { remove no entry from a withsymtable as it is only a pointer to the
  1475. recorddef or objectdef symtable }
  1476. end;
  1477. {****************************************************************************
  1478. TSTT_ExceptionSymtable
  1479. ****************************************************************************}
  1480. constructor tstt_exceptsymtable.create;
  1481. begin
  1482. inherited create('');
  1483. symtabletype:=stt_exceptsymtable;
  1484. end;
  1485. {*****************************************************************************
  1486. Helper Routines
  1487. *****************************************************************************}
  1488. function findunitsymtable(st:tsymtable):tsymtable;
  1489. begin
  1490. findunitsymtable:=nil;
  1491. repeat
  1492. if not assigned(st) then
  1493. internalerror(5566561);
  1494. case st.symtabletype of
  1495. localsymtable,
  1496. parasymtable,
  1497. staticsymtable :
  1498. exit;
  1499. globalsymtable :
  1500. begin
  1501. findunitsymtable:=st;
  1502. exit;
  1503. end;
  1504. objectsymtable :
  1505. st:=st.defowner.owner;
  1506. recordsymtable :
  1507. begin
  1508. { don't continue when the current
  1509. symtable is used for variant records }
  1510. if trecorddef(st.defowner).isunion then
  1511. begin
  1512. findunitsymtable:=nil;
  1513. exit;
  1514. end
  1515. else
  1516. st:=st.defowner.owner;
  1517. end;
  1518. else
  1519. internalerror(5566562);
  1520. end;
  1521. until false;
  1522. end;
  1523. procedure duplicatesym(sym:tsym);
  1524. var
  1525. st : tsymtable;
  1526. begin
  1527. Message1(sym_e_duplicate_id,sym.realname);
  1528. st:=findunitsymtable(sym.owner);
  1529. with sym.fileinfo do
  1530. begin
  1531. if assigned(st) and (st.unitid<>0) then
  1532. Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line))
  1533. else
  1534. Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line));
  1535. end;
  1536. end;
  1537. {*****************************************************************************
  1538. Search
  1539. *****************************************************************************}
  1540. function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  1541. var
  1542. speedvalue : cardinal;
  1543. begin
  1544. speedvalue:=getspeedvalue(s);
  1545. srsymtable:=symtablestack;
  1546. while assigned(srsymtable) do
  1547. begin
  1548. srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
  1549. if assigned(srsym) and
  1550. (not assigned(current_procinfo) or
  1551. tstoredsym(srsym).is_visible_for_proc(current_procinfo.procdef)) then
  1552. begin
  1553. searchsym:=true;
  1554. exit;
  1555. end
  1556. else
  1557. srsymtable:=srsymtable.next;
  1558. end;
  1559. searchsym:=false;
  1560. end;
  1561. function searchsym_type(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
  1562. var
  1563. speedvalue : cardinal;
  1564. begin
  1565. speedvalue:=getspeedvalue(s);
  1566. srsymtable:=symtablestack;
  1567. while assigned(srsymtable) do
  1568. begin
  1569. {
  1570. It is not possible to have type defintions in:
  1571. records
  1572. objects
  1573. parameters
  1574. }
  1575. if not(srsymtable.symtabletype in [recordsymtable,objectsymtable,parasymtable]) then
  1576. begin
  1577. srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
  1578. if assigned(srsym) and
  1579. (not assigned(current_procinfo) or
  1580. tstoredsym(srsym).is_visible_for_proc(current_procinfo.procdef)) then
  1581. begin
  1582. result:=true;
  1583. exit;
  1584. end
  1585. end;
  1586. srsymtable:=srsymtable.next;
  1587. end;
  1588. result:=false;
  1589. end;
  1590. function searchsymonlyin(p : tsymtable;const s : stringid):tsym;
  1591. var
  1592. srsym : tsym;
  1593. begin
  1594. { the caller have to take care if srsym=nil }
  1595. if assigned(p) then
  1596. begin
  1597. srsym:=tsym(p.search(s));
  1598. if assigned(srsym) then
  1599. begin
  1600. searchsymonlyin:=srsym;
  1601. exit;
  1602. end;
  1603. { also check in the local symtbale if it exists }
  1604. if (p=tsymtable(current_module.globalsymtable)) then
  1605. begin
  1606. srsym:=tsym(current_module.localsymtable.search(s));
  1607. if assigned(srsym) then
  1608. begin
  1609. searchsymonlyin:=srsym;
  1610. exit;
  1611. end;
  1612. end
  1613. end;
  1614. searchsymonlyin:=nil;
  1615. end;
  1616. function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
  1617. var
  1618. speedvalue : cardinal;
  1619. topclassh : tobjectdef;
  1620. sym : tsym;
  1621. begin
  1622. speedvalue:=getspeedvalue(s);
  1623. { when the class passed is defined in this unit we
  1624. need to use the scope of that class. This is a trick
  1625. that can be used to access protected members in other
  1626. units. At least kylix supports it this way (PFV) }
  1627. if assigned(classh) and
  1628. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1629. (classh.owner.unitid=0) then
  1630. topclassh:=classh
  1631. else
  1632. topclassh:=nil;
  1633. sym:=nil;
  1634. while assigned(classh) do
  1635. begin
  1636. sym:=tsym(classh.symtable.speedsearch(s,speedvalue));
  1637. if assigned(sym) then
  1638. begin
  1639. if assigned(topclassh) then
  1640. begin
  1641. if tstoredsym(sym).is_visible_for_object(topclassh) then
  1642. break;
  1643. end
  1644. else
  1645. begin
  1646. if (not assigned(current_procinfo) or
  1647. tstoredsym(sym).is_visible_for_proc(current_procinfo.procdef)) then
  1648. break;
  1649. end;
  1650. end;
  1651. classh:=classh.childof;
  1652. end;
  1653. searchsym_in_class:=sym;
  1654. end;
  1655. function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
  1656. var
  1657. topclassh : tobjectdef;
  1658. def : tdef;
  1659. sym : tsym;
  1660. begin
  1661. { when the class passed is defined in this unit we
  1662. need to use the scope of that class. This is a trick
  1663. that can be used to access protected members in other
  1664. units. At least kylix supports it this way (PFV) }
  1665. if assigned(classh) and
  1666. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1667. (classh.owner.unitid=0) then
  1668. topclassh:=classh
  1669. else
  1670. begin
  1671. if assigned(current_procinfo) then
  1672. topclassh:=current_procinfo.procdef._class
  1673. else
  1674. topclassh:=nil;
  1675. end;
  1676. sym:=nil;
  1677. def:=nil;
  1678. while assigned(classh) do
  1679. begin
  1680. def:=tdef(classh.symtable.defindex.first);
  1681. while assigned(def) do
  1682. begin
  1683. if (def.deftype=procdef) and
  1684. (po_msgint in tprocdef(def).procoptions) and
  1685. (tprocdef(def).messageinf.i=i) then
  1686. begin
  1687. sym:=tprocdef(def).procsym;
  1688. if assigned(topclassh) then
  1689. begin
  1690. if tprocdef(def).is_visible_for_object(topclassh) then
  1691. break;
  1692. end
  1693. else
  1694. break;
  1695. end;
  1696. def:=tdef(def.indexnext);
  1697. end;
  1698. if assigned(sym) then
  1699. break;
  1700. classh:=classh.childof;
  1701. end;
  1702. searchsym_in_class_by_msgint:=sym;
  1703. end;
  1704. function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
  1705. var
  1706. topclassh : tobjectdef;
  1707. def : tdef;
  1708. sym : tsym;
  1709. begin
  1710. { when the class passed is defined in this unit we
  1711. need to use the scope of that class. This is a trick
  1712. that can be used to access protected members in other
  1713. units. At least kylix supports it this way (PFV) }
  1714. if assigned(classh) and
  1715. (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1716. (classh.owner.unitid=0) then
  1717. topclassh:=classh
  1718. else
  1719. begin
  1720. if assigned(current_procinfo) then
  1721. topclassh:=current_procinfo.procdef._class
  1722. else
  1723. topclassh:=nil;
  1724. end;
  1725. sym:=nil;
  1726. def:=nil;
  1727. while assigned(classh) do
  1728. begin
  1729. def:=tdef(classh.symtable.defindex.first);
  1730. while assigned(def) do
  1731. begin
  1732. if (def.deftype=procdef) and
  1733. (po_msgstr in tprocdef(def).procoptions) and
  1734. (tprocdef(def).messageinf.str=s) then
  1735. begin
  1736. sym:=tprocdef(def).procsym;
  1737. if assigned(topclassh) then
  1738. begin
  1739. if tprocdef(def).is_visible_for_object(topclassh) then
  1740. break;
  1741. end
  1742. else
  1743. break;
  1744. end;
  1745. def:=tdef(def.indexnext);
  1746. end;
  1747. if assigned(sym) then
  1748. break;
  1749. classh:=classh.childof;
  1750. end;
  1751. searchsym_in_class_by_msgstr:=sym;
  1752. end;
  1753. function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
  1754. var
  1755. symowner: tsymtable;
  1756. begin
  1757. if not(cs_compilesystem in aktmoduleswitches) then
  1758. srsym := ttypesym(searchsymonlyin(systemunit,s))
  1759. else
  1760. searchsym(s,tsym(srsym),symowner);
  1761. searchsystype :=
  1762. assigned(srsym) and
  1763. (srsym.typ = typesym);
  1764. end;
  1765. function searchsysvar(const s: stringid; var srsym: tvarsym; var symowner: tsymtable): boolean;
  1766. begin
  1767. if not(cs_compilesystem in aktmoduleswitches) then
  1768. begin
  1769. srsym := tvarsym(searchsymonlyin(systemunit,s));
  1770. symowner := systemunit;
  1771. end
  1772. else
  1773. searchsym(s,tsym(srsym),symowner);
  1774. searchsysvar :=
  1775. assigned(srsym) and
  1776. (srsym.typ = varsym);
  1777. end;
  1778. function search_class_member(pd : tobjectdef;const s : string):tsym;
  1779. { searches n in symtable of pd and all anchestors }
  1780. var
  1781. speedvalue : cardinal;
  1782. srsym : tsym;
  1783. begin
  1784. speedvalue:=getspeedvalue(s);
  1785. while assigned(pd) do
  1786. begin
  1787. srsym:=tsym(pd.symtable.speedsearch(s,speedvalue));
  1788. if assigned(srsym) then
  1789. begin
  1790. search_class_member:=srsym;
  1791. exit;
  1792. end;
  1793. pd:=pd.childof;
  1794. end;
  1795. search_class_member:=nil;
  1796. end;
  1797. {*****************************************************************************
  1798. Definition Helpers
  1799. *****************************************************************************}
  1800. procedure globaldef(const s : string;var t:ttype);
  1801. var st : string;
  1802. symt : tsymtable;
  1803. srsym : tsym;
  1804. srsymtable : tsymtable;
  1805. begin
  1806. srsym := nil;
  1807. if pos('.',s) > 0 then
  1808. begin
  1809. st := copy(s,1,pos('.',s)-1);
  1810. searchsym(st,srsym,srsymtable);
  1811. st := copy(s,pos('.',s)+1,255);
  1812. if assigned(srsym) then
  1813. begin
  1814. if srsym.typ = unitsym then
  1815. begin
  1816. symt := tunitsym(srsym).unitsymtable;
  1817. srsym := tsym(symt.search(st));
  1818. end else srsym := nil;
  1819. end;
  1820. end else st := s;
  1821. if srsym = nil then
  1822. searchsym(st,srsym,srsymtable);
  1823. if srsym = nil then
  1824. srsym:=searchsymonlyin(systemunit,st);
  1825. if (not assigned(srsym)) or
  1826. (srsym.typ<>typesym) then
  1827. begin
  1828. Message(type_e_type_id_expected);
  1829. t:=generrortype;
  1830. exit;
  1831. end;
  1832. t := ttypesym(srsym).restype;
  1833. end;
  1834. {****************************************************************************
  1835. Object Helpers
  1836. ****************************************************************************}
  1837. var
  1838. _defaultprop : tpropertysym;
  1839. procedure tstoredsymtable.testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
  1840. begin
  1841. if (tsym(p).typ=propertysym) and
  1842. (ppo_defaultproperty in tpropertysym(p).propoptions) then
  1843. _defaultprop:=tpropertysym(p);
  1844. end;
  1845. function search_default_property(pd : tobjectdef) : tpropertysym;
  1846. { returns the default property of a class, searches also anchestors }
  1847. begin
  1848. _defaultprop:=nil;
  1849. while assigned(pd) do
  1850. begin
  1851. pd.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}tstoredsymtable(pd.symtable).testfordefaultproperty,nil);
  1852. if assigned(_defaultprop) then
  1853. break;
  1854. pd:=pd.childof;
  1855. end;
  1856. search_default_property:=_defaultprop;
  1857. end;
  1858. {$ifdef UNITALIASES}
  1859. {****************************************************************************
  1860. TUNIT_ALIAS
  1861. ****************************************************************************}
  1862. constructor tunit_alias.create(const n:string);
  1863. var
  1864. i : longint;
  1865. begin
  1866. i:=pos('=',n);
  1867. if i=0 then
  1868. fail;
  1869. inherited createname(Copy(n,1,i-1));
  1870. newname:=stringdup(Copy(n,i+1,255));
  1871. end;
  1872. destructor tunit_alias.destroy;
  1873. begin
  1874. stringdispose(newname);
  1875. inherited destroy;
  1876. end;
  1877. procedure addunitalias(const n:string);
  1878. begin
  1879. unitaliases^.insert(tunit_alias,init(Upper(n))));
  1880. end;
  1881. function getunitalias(const n:string):string;
  1882. var
  1883. p : punit_alias;
  1884. begin
  1885. p:=punit_alias(unitaliases^.search(Upper(n)));
  1886. if assigned(p) then
  1887. getunitalias:=punit_alias(p).newname^
  1888. else
  1889. getunitalias:=n;
  1890. end;
  1891. {$endif UNITALIASES}
  1892. {****************************************************************************
  1893. Symtable Stack
  1894. ****************************************************************************}
  1895. procedure RestoreUnitSyms;
  1896. var
  1897. p : tsymtable;
  1898. begin
  1899. p:=symtablestack;
  1900. while assigned(p) do
  1901. begin
  1902. if (p.symtabletype=globalsymtable) and
  1903. assigned(tglobalsymtable(p).unitsym) and
  1904. ((tglobalsymtable(p).unitsym.owner=current_module.globalsymtable) or
  1905. (tglobalsymtable(p).unitsym.owner=current_module.localsymtable)) then
  1906. tglobalsymtable(p).unitsym.restoreunitsym;
  1907. p:=p.next;
  1908. end;
  1909. end;
  1910. {$ifdef DEBUG}
  1911. procedure test_symtablestack;
  1912. var
  1913. p : tsymtable;
  1914. i : longint;
  1915. begin
  1916. p:=symtablestack;
  1917. i:=0;
  1918. while assigned(p) do
  1919. begin
  1920. inc(i);
  1921. p:=p.next;
  1922. if i>500 then
  1923. Message(sym_f_internal_error_in_symtablestack);
  1924. end;
  1925. end;
  1926. procedure list_symtablestack;
  1927. var
  1928. p : tsymtable;
  1929. i : longint;
  1930. begin
  1931. p:=symtablestack;
  1932. i:=0;
  1933. while assigned(p) do
  1934. begin
  1935. inc(i);
  1936. writeln(i,' ',p.name^);
  1937. p:=p.next;
  1938. if i>500 then
  1939. Message(sym_f_internal_error_in_symtablestack);
  1940. end;
  1941. end;
  1942. {$endif DEBUG}
  1943. {****************************************************************************
  1944. Init/Done Symtable
  1945. ****************************************************************************}
  1946. procedure InitSymtable;
  1947. var
  1948. token : ttoken;
  1949. begin
  1950. { Reset symbolstack }
  1951. registerdef:=false;
  1952. symtablestack:=nil;
  1953. systemunit:=nil;
  1954. {$ifdef GDB}
  1955. firstglobaldef:=nil;
  1956. lastglobaldef:=nil;
  1957. globaltypecount:=1;
  1958. pglobaltypecount:=@globaltypecount;
  1959. {$endif GDB}
  1960. { defs for internal use }
  1961. voidprocdef:=tprocdef.create(unknown_level);
  1962. { create error syms and def }
  1963. generrorsym:=terrorsym.create;
  1964. generrortype.setdef(terrordef.create);
  1965. {$ifdef UNITALIASES}
  1966. { unit aliases }
  1967. unitaliases:=tdictionary.create;
  1968. {$endif}
  1969. for token:=first_overloaded to last_overloaded do
  1970. overloaded_operators[token]:=nil;
  1971. end;
  1972. procedure DoneSymtable;
  1973. begin
  1974. voidprocdef.free;
  1975. generrorsym.free;
  1976. generrortype.def.free;
  1977. {$ifdef UNITALIASES}
  1978. unitaliases.free;
  1979. {$endif}
  1980. end;
  1981. end.
  1982. {
  1983. $Log$
  1984. Revision 1.113 2003-10-03 14:43:29 peter
  1985. * don't report unused hidden parameters
  1986. Revision 1.112 2003/10/02 21:13:46 peter
  1987. * protected visibility fixes
  1988. Revision 1.111 2003/10/01 19:05:33 peter
  1989. * searchsym_type to search for type definitions. It ignores
  1990. records,objects and parameters
  1991. Revision 1.110 2003/09/23 17:56:06 peter
  1992. * locals and paras are allocated in the code generation
  1993. * tvarsym.localloc contains the location of para/local when
  1994. generating code for the current procedure
  1995. Revision 1.109 2003/08/23 22:31:08 peter
  1996. * unchain operators before adding to overloaded list
  1997. Revision 1.108 2003/06/25 18:31:23 peter
  1998. * sym,def resolving partly rewritten to support also parent objects
  1999. not directly available through the uses clause
  2000. Revision 1.107 2003/06/13 21:19:31 peter
  2001. * current_procdef removed, use current_procinfo.procdef instead
  2002. Revision 1.106 2003/06/09 18:26:27 peter
  2003. * para can be the same as function name in delphi
  2004. Revision 1.105 2003/06/08 11:40:00 peter
  2005. * check parast when inserting in localst
  2006. Revision 1.104 2003/06/07 20:26:32 peter
  2007. * re-resolving added instead of reloading from ppu
  2008. * tderef object added to store deref info for resolving
  2009. Revision 1.103 2003/05/25 11:34:17 peter
  2010. * methodpointer self pushing fixed
  2011. Revision 1.102 2003/05/23 14:27:35 peter
  2012. * remove some unit dependencies
  2013. * current_procinfo changes to store more info
  2014. Revision 1.101 2003/05/16 14:32:58 peter
  2015. * fix dup check for hiding the result varsym in localst, the result
  2016. sym was already in the localst when adding the locals
  2017. Revision 1.100 2003/05/15 18:58:53 peter
  2018. * removed selfpointer_offset, vmtpointer_offset
  2019. * tvarsym.adjusted_address
  2020. * address in localsymtable is now in the real direction
  2021. * removed some obsolete globals
  2022. Revision 1.99 2003/05/13 15:17:13 peter
  2023. * fix crash with hiding function result. The function result is now
  2024. inserted as last so the symbol that we are going to insert is the
  2025. result and needs to be renamed instead of the already existing
  2026. symbol
  2027. Revision 1.98 2003/05/11 14:45:12 peter
  2028. * tloadnode does not support objectsymtable,withsymtable anymore
  2029. * withnode cleanup
  2030. * direct with rewritten to use temprefnode
  2031. Revision 1.97 2003/04/27 11:21:34 peter
  2032. * aktprocdef renamed to current_procinfo.procdef
  2033. * procinfo renamed to current_procinfo
  2034. * procinfo will now be stored in current_module so it can be
  2035. cleaned up properly
  2036. * gen_main_procsym changed to create_main_proc and release_main_proc
  2037. to also generate a tprocinfo structure
  2038. * fixed unit implicit initfinal
  2039. Revision 1.96 2003/04/27 07:29:51 peter
  2040. * current_procinfo.procdef cleanup, current_procdef is now always nil when parsing
  2041. a new procdef declaration
  2042. * aktprocsym removed
  2043. * lexlevel removed, use symtable.symtablelevel instead
  2044. * implicit init/final code uses the normal genentry/genexit
  2045. * funcret state checking updated for new funcret handling
  2046. Revision 1.95 2003/04/26 00:33:07 peter
  2047. * vo_is_result flag added for the special RESULT symbol
  2048. Revision 1.94 2003/04/25 20:59:35 peter
  2049. * removed funcretn,funcretsym, function result is now in varsym
  2050. and aliases for result and function name are added using absolutesym
  2051. * vs_hidden parameter for funcret passed in parameter
  2052. * vs_hidden fixes
  2053. * writenode changed to printnode and released from extdebug
  2054. * -vp option added to generate a tree.log with the nodetree
  2055. * nicer printnode for statements, callnode
  2056. Revision 1.93 2003/04/16 07:53:11 jonas
  2057. * calculation of parameter and resultlocation offsets now depends on
  2058. tg.direction instead of if(n)def powerpc
  2059. Revision 1.92 2003/04/05 21:09:32 jonas
  2060. * several ppc/generic result offset related fixes. The "normal" result
  2061. offset seems now to be calculated correctly and a lot of duplicate
  2062. calculations have been removed. Nested functions accessing the parent's
  2063. function result don't work at all though :(
  2064. Revision 1.91 2003/03/17 18:56:49 peter
  2065. * ignore hints for default parameter values
  2066. Revision 1.90 2003/03/17 16:54:41 peter
  2067. * support DefaultHandler and anonymous inheritance fixed
  2068. for message methods
  2069. Revision 1.89 2002/12/29 14:57:50 peter
  2070. * unit loading changed to first register units and load them
  2071. afterwards. This is needed to support uses xxx in yyy correctly
  2072. * unit dependency check fixed
  2073. Revision 1.88 2002/12/27 18:07:45 peter
  2074. * fix crashes when searching symbols
  2075. Revision 1.87 2002/12/25 01:26:56 peter
  2076. * duplicate procsym-unitsym fix
  2077. Revision 1.86 2002/12/21 13:07:34 peter
  2078. * type redefine fix for tb0437
  2079. Revision 1.85 2002/12/07 14:27:10 carl
  2080. * 3% memory optimization
  2081. * changed some types
  2082. + added type checking with different size for call node and for
  2083. parameters
  2084. Revision 1.84 2002/12/06 17:51:11 peter
  2085. * merged cdecl and array fixes
  2086. Revision 1.83 2002/11/30 11:12:48 carl
  2087. + checking for symbols used with hint directives is done mostly in pexpr
  2088. only now
  2089. Revision 1.82 2002/11/29 22:31:20 carl
  2090. + unimplemented hint directive added
  2091. * hint directive parsing implemented
  2092. * warning on these directives
  2093. Revision 1.81 2002/11/27 20:04:09 peter
  2094. * tvarsym.get_push_size replaced by paramanager.push_size
  2095. Revision 1.80 2002/11/22 22:45:49 carl
  2096. + small optimization for speed
  2097. Revision 1.79 2002/11/19 16:26:33 pierre
  2098. * correct a stabs generation problem that lead to use errordef in stabs
  2099. Revision 1.78 2002/11/18 17:32:00 peter
  2100. * pass proccalloption to ret_in_xxx and push_xxx functions
  2101. Revision 1.77 2002/11/15 01:58:54 peter
  2102. * merged changes from 1.0.7 up to 04-11
  2103. - -V option for generating bug report tracing
  2104. - more tracing for option parsing
  2105. - errors for cdecl and high()
  2106. - win32 import stabs
  2107. - win32 records<=8 are returned in eax:edx (turned off by default)
  2108. - heaptrc update
  2109. - more info for temp management in .s file with EXTDEBUG
  2110. Revision 1.76 2002/11/09 15:29:28 carl
  2111. + bss / constant alignment fixes
  2112. * avoid incrementing address/datasize in local symtable for const's
  2113. Revision 1.75 2002/10/14 19:44:43 peter
  2114. * threadvars need 4 bytes extra for storing the threadvar index
  2115. Revision 1.74 2002/10/06 19:41:31 peter
  2116. * Add finalization of typed consts
  2117. * Finalization of globals in the main program
  2118. Revision 1.73 2002/10/05 12:43:29 carl
  2119. * fixes for Delphi 6 compilation
  2120. (warning : Some features do not work under Delphi)
  2121. Revision 1.72 2002/09/09 19:41:46 peter
  2122. * real fix internalerror for dup ids in union sym
  2123. Revision 1.71 2002/09/09 17:34:16 peter
  2124. * tdicationary.replace added to replace and item in a dictionary. This
  2125. is only allowed for the same name
  2126. * varsyms are inserted in symtable before the types are parsed. This
  2127. fixes the long standing "var longint : longint" bug
  2128. - consume_idlist and idstringlist removed. The loops are inserted
  2129. at the callers place and uses the symtable for duplicate id checking
  2130. Revision 1.70 2002/09/05 19:29:45 peter
  2131. * memdebug enhancements
  2132. Revision 1.69 2002/08/25 19:25:21 peter
  2133. * sym.insert_in_data removed
  2134. * symtable.insertvardata/insertconstdata added
  2135. * removed insert_in_data call from symtable.insert, it needs to be
  2136. called separatly. This allows to deref the address calculation
  2137. * procedures now calculate the parast addresses after the procedure
  2138. directives are parsed. This fixes the cdecl parast problem
  2139. * push_addr_param has an extra argument that specifies if cdecl is used
  2140. or not
  2141. Revision 1.68 2002/08/18 20:06:27 peter
  2142. * inlining is now also allowed in interface
  2143. * renamed write/load to ppuwrite/ppuload
  2144. * tnode storing in ppu
  2145. * nld,ncon,nbas are already updated for storing in ppu
  2146. Revision 1.67 2002/08/17 09:23:43 florian
  2147. * first part of procinfo rewrite
  2148. Revision 1.66 2002/08/11 13:24:15 peter
  2149. * saving of asmsymbols in ppu supported
  2150. * asmsymbollist global is removed and moved into a new class
  2151. tasmlibrarydata that will hold the info of a .a file which
  2152. corresponds with a single module. Added librarydata to tmodule
  2153. to keep the library info stored for the module. In the future the
  2154. objectfiles will also be stored to the tasmlibrarydata class
  2155. * all getlabel/newasmsymbol and friends are moved to the new class
  2156. Revision 1.65 2002/07/23 09:51:27 daniel
  2157. * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
  2158. are worth comitting.
  2159. Revision 1.64 2002/07/16 15:34:21 florian
  2160. * exit is now a syssym instead of a keyword
  2161. Revision 1.63 2002/07/15 19:44:53 florian
  2162. * fixed crash with default parameters and stdcall calling convention
  2163. Revision 1.62 2002/07/01 18:46:28 peter
  2164. * internal linker
  2165. * reorganized aasm layer
  2166. Revision 1.61 2002/05/18 13:34:19 peter
  2167. * readded missing revisions
  2168. Revision 1.60 2002/05/16 19:46:45 carl
  2169. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  2170. + try to fix temp allocation (still in ifdef)
  2171. + generic constructor calls
  2172. + start of tassembler / tmodulebase class cleanup
  2173. Revision 1.58 2002/05/12 16:53:15 peter
  2174. * moved entry and exitcode to ncgutil and cgobj
  2175. * foreach gets extra argument for passing local data to the
  2176. iterator function
  2177. * -CR checks also class typecasts at runtime by changing them
  2178. into as
  2179. * fixed compiler to cycle with the -CR option
  2180. * fixed stabs with elf writer, finally the global variables can
  2181. be watched
  2182. * removed a lot of routines from cga unit and replaced them by
  2183. calls to cgobj
  2184. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  2185. u32bit then the other is typecasted also to u32bit without giving
  2186. a rangecheck warning/error.
  2187. * fixed pascal calling method with reversing also the high tree in
  2188. the parast, detected by tcalcst3 test
  2189. Revision 1.57 2002/04/04 19:06:05 peter
  2190. * removed unused units
  2191. * use tlocation.size in cg.a_*loc*() routines
  2192. Revision 1.56 2002/03/04 19:10:11 peter
  2193. * removed compiler warnings
  2194. Revision 1.55 2002/02/03 09:30:07 peter
  2195. * more fixes for protected handling
  2196. Revision 1.54 2002/01/29 21:30:25 peter
  2197. * allow also dup id in delphi mode in interfaces
  2198. Revision 1.53 2002/01/29 19:46:00 peter
  2199. * fixed recordsymtable.insert_in() for inserting variant record fields
  2200. to not used symtable.insert() because that also updates alignmentinfo
  2201. which was already set
  2202. Revision 1.52 2002/01/24 18:25:50 peter
  2203. * implicit result variable generation for assembler routines
  2204. * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
  2205. }