symtable.pas 76 KB

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