symtable.pas 81 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 defines.inc}
  20. interface
  21. uses
  22. { common }
  23. cutils,cobjects,
  24. { global }
  25. globtype,tokens,
  26. { symtable }
  27. symconst,symbase,symtype,symdef,symsym,
  28. { assembler }
  29. aasm
  30. ;
  31. {****************************************************************************
  32. Symtable types
  33. ****************************************************************************}
  34. type
  35. pstoredsymtable = ^tstoredsymtable;
  36. tstoredsymtable = object(tsymtable)
  37. constructor init(t : tsymtabletype);
  38. { load/write }
  39. constructor loadas(typ : tsymtabletype);
  40. procedure writeas;
  41. procedure loaddefs;
  42. procedure loadsyms;
  43. procedure writedefs;
  44. procedure writesyms;
  45. procedure prederef;
  46. procedure deref;
  47. procedure insert(sym : psymentry);virtual;
  48. procedure insert_in(psymt : psymtable;offset : longint);
  49. function speedsearch(const s : stringid;speedvalue : longint) : psymentry;virtual;
  50. procedure allsymbolsused;
  51. procedure allprivatesused;
  52. procedure allunitsused;
  53. procedure check_forwards;
  54. procedure checklabels;
  55. { change alignment for args only parasymtable }
  56. procedure set_alignment(_alignment : longint);
  57. {$ifdef CHAINPROCSYMS}
  58. procedure chainprocsyms;
  59. {$endif CHAINPROCSYMS}
  60. {$ifndef DONOTCHAINOPERATORS}
  61. procedure chainoperators;
  62. {$endif DONOTCHAINOPERATORS}
  63. procedure load_browser;
  64. procedure write_browser;
  65. {$ifdef GDB}
  66. procedure concatstabto(asmlist : taasmoutput);virtual;
  67. function getnewtypecount : word; virtual;
  68. {$endif GDB}
  69. end;
  70. punitsymtable = ^tunitsymtable;
  71. tunitsymtable = object(tstoredsymtable)
  72. unittypecount : word;
  73. unitsym : punitsym;
  74. {$ifdef GDB}
  75. dbx_count : longint;
  76. prev_dbx_counter : plongint;
  77. dbx_count_ok : boolean;
  78. is_stab_written : boolean;
  79. {$endif GDB}
  80. constructor init(t : tsymtabletype;const n : string);
  81. constructor loadasunit;
  82. destructor done;virtual;
  83. procedure writeasunit;
  84. {$ifdef GDB}
  85. procedure concattypestabto(asmlist : taasmoutput);
  86. function getnewtypecount : word; virtual;
  87. {$endif GDB}
  88. procedure load_symtable_refs;
  89. end;
  90. pwithsymtable = ^twithsymtable;
  91. twithsymtable = object(tsymtable)
  92. { used for withsymtable for allowing constructors }
  93. direct_with : boolean;
  94. { in fact it is a ptree }
  95. withnode : pointer;
  96. { ptree to load of direct with var }
  97. { already usable before firstwith
  98. needed for firstpass of function parameters PM }
  99. withrefnode : pointer;
  100. constructor init;
  101. destructor done;virtual;
  102. procedure clear;virtual;
  103. end;
  104. var
  105. constsymtable : psymtable; { symtable were the constants can be inserted }
  106. systemunit : punitsymtable; { pointer to the system unit }
  107. read_member : boolean; { reading members of an symtable }
  108. lexlevel : longint; { level of code }
  109. { 1 for main procedure }
  110. { 2 for normal function or proc }
  111. { higher for locals }
  112. {****************************************************************************
  113. Functions
  114. ****************************************************************************}
  115. {*** Misc ***}
  116. function globaldef(const s : string) : pdef;
  117. function findunitsymtable(st:psymtable):psymtable;
  118. procedure duplicatesym(sym:psym);
  119. procedure identifier_not_found(const s:string);
  120. {*** Search ***}
  121. function searchsym(const s : stringid;var srsym:psym;var srsymtable:psymtable):boolean;
  122. function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym;
  123. function searchsymonlyin(p : psymtable;const s : stringid):psym;
  124. function search_class_member(pd : pobjectdef;const s : string):psym;
  125. {*** PPU Write/Loading ***}
  126. procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
  127. procedure numberunits;
  128. procedure load_interface;
  129. {*** Object Helpers ***}
  130. function search_default_property(pd : pobjectdef) : ppropertysym;
  131. {*** symtable stack ***}
  132. procedure dellexlevel;
  133. procedure RestoreUnitSyms;
  134. {$ifdef DEBUG}
  135. procedure test_symtablestack;
  136. procedure list_symtablestack;
  137. {$endif DEBUG}
  138. {$ifdef UNITALIASES}
  139. type
  140. punit_alias = ^tunit_alias;
  141. tunit_alias = object(tnamedindexobject)
  142. newname : pstring;
  143. constructor init(const n:string);
  144. destructor done;virtual;
  145. end;
  146. var
  147. unitaliases : pdictionary;
  148. procedure addunitalias(const n:string);
  149. function getunitalias(const n:string):string;
  150. {$endif UNITALIASES}
  151. {*** Init / Done ***}
  152. procedure InitSymtable;
  153. procedure DoneSymtable;
  154. const
  155. { last operator which can be overloaded, the first_overloaded should
  156. be in tokens.pas after NOTOKEN }
  157. first_overloaded = _PLUS;
  158. last_overloaded = _ASSIGNMENT;
  159. type
  160. toverloaded_operators = array[NOTOKEN..last_overloaded] of pprocsym;
  161. var
  162. overloaded_operators : toverloaded_operators;
  163. { unequal is not equal}
  164. const
  165. overloaded_names : array [NOTOKEN..last_overloaded] of string[16] =
  166. ('error',
  167. 'plus','minus','star','slash','equal',
  168. 'greater','lower','greater_or_equal',
  169. 'lower_or_equal',
  170. 'sym_diff','starstar',
  171. 'as','is','in','or',
  172. 'and','div','mod','not','shl','shr','xor',
  173. 'assign');
  174. implementation
  175. uses
  176. { global }
  177. version,verbose,globals,
  178. { target }
  179. systems,
  180. { ppu }
  181. symppu,ppu,
  182. { module }
  183. finput,fmodule,
  184. {$ifdef GDB}
  185. gdb,
  186. {$endif GDB}
  187. { scanner }
  188. scanner,
  189. { codegen }
  190. hcodegen
  191. ;
  192. var
  193. in_loading : boolean; { remove !!! }
  194. {*****************************************************************************
  195. Symbol Call Back Functions
  196. *****************************************************************************}
  197. procedure write_refs(sym : pnamedindexobject);
  198. begin
  199. pstoredsym(sym)^.write_references;
  200. end;
  201. procedure check_forward(sym : pnamedindexobject);
  202. begin
  203. if psym(sym)^.typ=procsym then
  204. pprocsym(sym)^.check_forward
  205. { check also object method table }
  206. { we needn't to test the def list }
  207. { because each object has to have a type sym }
  208. else
  209. if (psym(sym)^.typ=typesym) and
  210. assigned(ptypesym(sym)^.restype.def) and
  211. (ptypesym(sym)^.restype.def^.deftype=objectdef) then
  212. pobjectdef(ptypesym(sym)^.restype.def)^.check_forwards;
  213. end;
  214. procedure labeldefined(p : pnamedindexobject);
  215. begin
  216. if (psym(p)^.typ=labelsym) and
  217. not(plabelsym(p)^.defined) then
  218. begin
  219. if plabelsym(p)^.used then
  220. Message1(sym_e_label_used_and_not_defined,plabelsym(p)^.realname)
  221. else
  222. Message1(sym_w_label_not_defined,plabelsym(p)^.realname);
  223. end;
  224. end;
  225. procedure unitsymbolused(p : pnamedindexobject);
  226. begin
  227. if (psym(p)^.typ=unitsym) and
  228. (punitsym(p)^.refs=0) and
  229. { do not claim for unit name itself !! }
  230. (punitsym(p)^.unitsymtable^.symtabletype=unitsymtable) then
  231. MessagePos2(psym(p)^.fileinfo,sym_n_unit_not_used,
  232. p^.name,current_module.modulename^);
  233. end;
  234. procedure varsymbolused(p : pnamedindexobject);
  235. begin
  236. if (psym(p)^.typ=varsym) and
  237. ((psym(p)^.owner^.symtabletype in
  238. [parasymtable,localsymtable,objectsymtable,staticsymtable])) then
  239. begin
  240. { unused symbol should be reported only if no }
  241. { error is reported }
  242. { if the symbol is in a register it is used }
  243. { also don't count the value parameters which have local copies }
  244. { also don't claim for high param of open parameters (PM) }
  245. if (Errorcount<>0) or
  246. (copy(p^.name,1,3)='val') or
  247. (copy(p^.name,1,4)='high') then
  248. exit;
  249. if (pvarsym(p)^.refs=0) then
  250. begin
  251. if (psym(p)^.owner^.symtabletype=parasymtable) or (vo_is_local_copy in pvarsym(p)^.varoptions) then
  252. begin
  253. MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_not_used,psym(p)^.realname);
  254. end
  255. else if (psym(p)^.owner^.symtabletype=objectsymtable) then
  256. MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_not_used,psym(p)^.owner^.name^,psym(p)^.realname)
  257. else
  258. MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_not_used,psym(p)^.realname);
  259. end
  260. else if pvarsym(p)^.varstate=vs_assigned then
  261. begin
  262. if (psym(p)^.owner^.symtabletype=parasymtable) then
  263. begin
  264. if not(pvarsym(p)^.varspez in [vs_var,vs_out]) then
  265. MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,psym(p)^.realname)
  266. end
  267. else if (vo_is_local_copy in pvarsym(p)^.varoptions) then
  268. begin
  269. if not(pvarsym(p)^.varspez in [vs_var,vs_out]) then
  270. MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,psym(p)^.realname);
  271. end
  272. else if (psym(p)^.owner^.symtabletype=objectsymtable) then
  273. MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_only_set,psym(p)^.owner^.name^,psym(p)^.realname)
  274. else if (psym(p)^.owner^.symtabletype<>parasymtable) then
  275. if not (vo_is_exported in pvarsym(p)^.varoptions) then
  276. MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_only_set,psym(p)^.realname);
  277. end;
  278. end
  279. else if ((psym(p)^.owner^.symtabletype in
  280. [objectsymtable,parasymtable,localsymtable,staticsymtable])) then
  281. begin
  282. if (Errorcount<>0) then
  283. exit;
  284. { do not claim for inherited private fields !! }
  285. if (pstoredsym(p)^.refs=0) and (psym(p)^.owner^.symtabletype=objectsymtable) then
  286. MessagePos2(psym(p)^.fileinfo,sym_n_private_method_not_used,psym(p)^.owner^.name^,psym(p)^.realname)
  287. { units references are problematic }
  288. else if (pstoredsym(p)^.refs=0) and not(psym(p)^.typ in [funcretsym,enumsym,unitsym]) then
  289. if (psym(p)^.typ<>procsym) or not (pprocsym(p)^.is_global) or
  290. { all program functions are declared global
  291. but unused should still be signaled PM }
  292. ((psym(p)^.owner^.symtabletype=staticsymtable) and
  293. not current_module.is_unit) then
  294. MessagePos2(psym(p)^.fileinfo,sym_h_local_symbol_not_used,SymTypeName[psym(p)^.typ],psym(p)^.realname);
  295. end;
  296. end;
  297. procedure TestPrivate(p : pnamedindexobject);
  298. begin
  299. if sp_private in psym(p)^.symoptions then
  300. varsymbolused(p);
  301. end;
  302. procedure objectprivatesymbolused(p : pnamedindexobject);
  303. begin
  304. {
  305. Don't test simple object aliases PM
  306. }
  307. if (psym(p)^.typ=typesym) and
  308. (ptypesym(p)^.restype.def^.deftype=objectdef) and
  309. (ptypesym(p)^.restype.def^.typesym=psym(p)) then
  310. pobjectdef(ptypesym(p)^.restype.def)^.symtable^.foreach(
  311. {$ifdef FPCPROCVAR}@{$endif}TestPrivate);
  312. end;
  313. {$ifdef GDB}
  314. var
  315. asmoutput : taasmoutput;
  316. procedure concatstab(p : pnamedindexobject);
  317. begin
  318. if psym(p)^.typ <> procsym then
  319. pstoredsym(p)^.concatstabto(asmoutput);
  320. end;
  321. procedure resetstab(p : pnamedindexobject);
  322. begin
  323. if psym(p)^.typ <> procsym then
  324. pstoredsym(p)^.isstabwritten:=false;
  325. end;
  326. procedure concattypestab(p : pnamedindexobject);
  327. begin
  328. if psym(p)^.typ = typesym then
  329. begin
  330. pstoredsym(p)^.isstabwritten:=false;
  331. pstoredsym(p)^.concatstabto(asmoutput);
  332. end;
  333. end;
  334. {$endif GDB}
  335. {$ifdef CHAINPROCSYMS}
  336. procedure chainprocsym(p : psym);
  337. var
  338. storesymtablestack : psymtable;
  339. srsym : psym;
  340. srsymtable : psymtable;
  341. begin
  342. if p^.typ=procsym then
  343. begin
  344. storesymtablestack:=symtablestack;
  345. symtablestack:=p^.owner^.next;
  346. while assigned(symtablestack) do
  347. begin
  348. { search for same procsym in other units }
  349. searchsym(p^.name,srsym,srsymtable)
  350. if assigned(srsym) and
  351. (srsym^.typ=procsym) then
  352. begin
  353. pprocsym(p)^.nextprocsym:=pprocsym(srsym);
  354. symtablestack:=storesymtablestack;
  355. exit;
  356. end
  357. else if srsym=nil then
  358. symtablestack:=nil
  359. else
  360. symtablestack:=srsymtable^.next;
  361. end;
  362. symtablestack:=storesymtablestack;
  363. end;
  364. end;
  365. {$endif}
  366. {****************************************************************************
  367. STORED SYMTABLE
  368. ****************************************************************************}
  369. constructor tstoredsymtable.init(t : tsymtabletype);
  370. begin
  371. symtabletype:=t;
  372. symtablelevel:=0;
  373. defowner:=nil;
  374. unitid:=0;
  375. next:=nil;
  376. name:=nil;
  377. address_fixup:=0;
  378. datasize:=0;
  379. if t=parasymtable then
  380. dataalignment:=4
  381. else
  382. dataalignment:=1;
  383. new(symindex,init(indexgrowsize));
  384. new(defindex,init(indexgrowsize));
  385. if symtabletype<>withsymtable then
  386. begin
  387. new(symsearch,init);
  388. symsearch^.noclear:=true;
  389. end
  390. else
  391. symsearch:=nil;
  392. end;
  393. {$ifndef DONOTCHAINOPERATORS}
  394. procedure tstoredsymtable.chainoperators;
  395. var
  396. p : pprocsym;
  397. t : ttoken;
  398. def : pprocdef;
  399. srsym : psym;
  400. srsymtable,
  401. storesymtablestack : psymtable;
  402. begin
  403. storesymtablestack:=symtablestack;
  404. symtablestack:=@self;
  405. make_ref:=false;
  406. for t:=first_overloaded to last_overloaded do
  407. begin
  408. p:=nil;
  409. def:=nil;
  410. overloaded_operators[t]:=nil;
  411. { each operator has a unique lowercased internal name PM }
  412. while assigned(symtablestack) do
  413. begin
  414. searchsym(overloaded_names[t],srsym,srsymtable);
  415. if not assigned(srsym) then
  416. begin
  417. if (t=_STARSTAR) then
  418. begin
  419. symtablestack:=systemunit;
  420. searchsym('POWER',srsym,srsymtable);
  421. end;
  422. end;
  423. if assigned(srsym) then
  424. begin
  425. if (srsym^.typ<>procsym) then
  426. internalerror(12344321);
  427. if assigned(p) then
  428. begin
  429. {$ifdef CHAINPROCSYMS}
  430. p^.nextprocsym:=pprocsym(srsym);
  431. {$endif CHAINPROCSYMS}
  432. def^.nextoverloaded:=pprocsym(srsym)^.definition;
  433. end
  434. else
  435. overloaded_operators[t]:=pprocsym(srsym);
  436. p:=pprocsym(srsym);
  437. def:=p^.definition;
  438. while assigned(def^.nextoverloaded) and
  439. (def^.nextoverloaded^.owner=p^.owner) do
  440. def:=def^.nextoverloaded;
  441. def^.nextoverloaded:=nil;
  442. symtablestack:=srsym^.owner^.next;
  443. end
  444. else
  445. begin
  446. symtablestack:=nil;
  447. {$ifdef CHAINPROCSYMS}
  448. if assigned(p) then
  449. p^.nextprocsym:=nil;
  450. {$endif CHAINPROCSYMS}
  451. end;
  452. { search for same procsym in other units }
  453. end;
  454. symtablestack:=@self;
  455. end;
  456. make_ref:=true;
  457. symtablestack:=storesymtablestack;
  458. end;
  459. {$endif DONOTCHAINOPERATORS}
  460. procedure tstoredsymtable.loaddefs;
  461. var
  462. hp : pdef;
  463. b : byte;
  464. begin
  465. { load start of definition section, which holds the amount of defs }
  466. if current_ppu^.readentry<>ibstartdefs then
  467. Message(unit_f_ppu_read_error);
  468. current_ppu^.getlongint;
  469. { read definitions }
  470. repeat
  471. b:=current_ppu^.readentry;
  472. case b of
  473. ibpointerdef : hp:=new(ppointerdef,load);
  474. ibarraydef : hp:=new(parraydef,load);
  475. iborddef : hp:=new(porddef,load);
  476. ibfloatdef : hp:=new(pfloatdef,load);
  477. ibprocdef : hp:=new(pprocdef,load);
  478. ibshortstringdef : hp:=new(pstringdef,shortload);
  479. iblongstringdef : hp:=new(pstringdef,longload);
  480. ibansistringdef : hp:=new(pstringdef,ansiload);
  481. ibwidestringdef : hp:=new(pstringdef,wideload);
  482. ibrecorddef : hp:=new(precorddef,load);
  483. ibobjectdef : hp:=new(pobjectdef,load);
  484. ibenumdef : hp:=new(penumdef,load);
  485. ibsetdef : hp:=new(psetdef,load);
  486. ibprocvardef : hp:=new(pprocvardef,load);
  487. ibfiledef : hp:=new(pfiledef,load);
  488. ibclassrefdef : hp:=new(pclassrefdef,load);
  489. ibformaldef : hp:=new(pformaldef,load);
  490. ibenddefs : break;
  491. ibend : Message(unit_f_ppu_read_error);
  492. else
  493. Message1(unit_f_ppu_invalid_entry,tostr(b));
  494. end;
  495. hp^.owner:=@self;
  496. defindex^.insert(hp);
  497. until false;
  498. end;
  499. procedure tstoredsymtable.loadsyms;
  500. var
  501. b : byte;
  502. sym : psym;
  503. begin
  504. { load start of definition section, which holds the amount of defs }
  505. if current_ppu^.readentry<>ibstartsyms then
  506. Message(unit_f_ppu_read_error);
  507. { skip amount of symbols, not used currently }
  508. current_ppu^.getlongint;
  509. { load datasize,dataalignment of this symboltable }
  510. datasize:=current_ppu^.getlongint;
  511. dataalignment:=current_ppu^.getlongint;
  512. { now read the symbols }
  513. repeat
  514. b:=current_ppu^.readentry;
  515. case b of
  516. ibtypesym : sym:=new(ptypesym,load);
  517. ibprocsym : sym:=new(pprocsym,load);
  518. ibconstsym : sym:=new(pconstsym,load);
  519. ibvarsym : sym:=new(pvarsym,load);
  520. ibfuncretsym : sym:=new(pfuncretsym,load);
  521. ibabsolutesym : sym:=new(pabsolutesym,load);
  522. ibenumsym : sym:=new(penumsym,load);
  523. ibtypedconstsym : sym:=new(ptypedconstsym,load);
  524. ibpropertysym : sym:=new(ppropertysym,load);
  525. ibunitsym : sym:=new(punitsym,load);
  526. iblabelsym : sym:=new(plabelsym,load);
  527. ibsyssym : sym:=new(psyssym,load);
  528. ibendsyms : break;
  529. ibend : Message(unit_f_ppu_read_error);
  530. else
  531. Message1(unit_f_ppu_invalid_entry,tostr(b));
  532. end;
  533. sym^.owner:=@self;
  534. symindex^.insert(sym);
  535. symsearch^.insert(sym);
  536. until false;
  537. end;
  538. procedure tstoredsymtable.writedefs;
  539. var
  540. pd : pstoreddef;
  541. begin
  542. { each definition get a number, write then the amount of defs to the
  543. ibstartdef entry }
  544. current_ppu^.putlongint(defindex^.count);
  545. current_ppu^.writeentry(ibstartdefs);
  546. { now write the definition }
  547. pd:=pstoreddef(defindex^.first);
  548. while assigned(pd) do
  549. begin
  550. pd^.write;
  551. pd:=pstoreddef(pd^.indexnext);
  552. end;
  553. { write end of definitions }
  554. current_ppu^.writeentry(ibenddefs);
  555. end;
  556. procedure tstoredsymtable.writesyms;
  557. var
  558. pd : pstoredsym;
  559. begin
  560. { each definition get a number, write then the amount of syms and the
  561. datasize to the ibsymdef entry }
  562. current_ppu^.putlongint(symindex^.count);
  563. current_ppu^.putlongint(datasize);
  564. current_ppu^.putlongint(dataalignment);
  565. current_ppu^.writeentry(ibstartsyms);
  566. { foreach is used to write all symbols }
  567. pd:=pstoredsym(symindex^.first);
  568. while assigned(pd) do
  569. begin
  570. pd^.write;
  571. pd:=pstoredsym(pd^.indexnext);
  572. end;
  573. { end of symbols }
  574. current_ppu^.writeentry(ibendsyms);
  575. end;
  576. {***********************************************
  577. Browser
  578. ***********************************************}
  579. procedure tstoredsymtable.load_browser;
  580. var
  581. b : byte;
  582. sym : pstoredsym;
  583. prdef : pstoreddef;
  584. oldrecsyms : psymtable;
  585. begin
  586. if symtabletype in [recordsymtable,objectsymtable] then
  587. begin
  588. oldrecsyms:=aktrecordsymtable;
  589. aktrecordsymtable:=@self;
  590. end;
  591. if symtabletype in [parasymtable,localsymtable] then
  592. begin
  593. oldrecsyms:=aktlocalsymtable;
  594. aktlocalsymtable:=@self;
  595. end;
  596. if symtabletype=staticppusymtable then
  597. aktstaticsymtable:=@self;
  598. b:=current_ppu^.readentry;
  599. if b <> ibbeginsymtablebrowser then
  600. Message1(unit_f_ppu_invalid_entry,tostr(b));
  601. repeat
  602. b:=current_ppu^.readentry;
  603. case b of
  604. ibsymref : begin
  605. sym:=pstoredsym(readderef);
  606. resolvesym(sym);
  607. if assigned(sym) then
  608. sym^.load_references;
  609. end;
  610. ibdefref : begin
  611. prdef:=pstoreddef(readderef);
  612. resolvedef(prdef);
  613. if assigned(prdef) then
  614. begin
  615. if prdef^.deftype<>procdef then
  616. Message(unit_f_ppu_read_error);
  617. pprocdef(prdef)^.load_references;
  618. end;
  619. end;
  620. ibendsymtablebrowser : break;
  621. else
  622. Message1(unit_f_ppu_invalid_entry,tostr(b));
  623. end;
  624. until false;
  625. if symtabletype in [recordsymtable,objectsymtable] then
  626. aktrecordsymtable:=oldrecsyms;
  627. if symtabletype in [parasymtable,localsymtable] then
  628. aktlocalsymtable:=oldrecsyms;
  629. end;
  630. procedure tstoredsymtable.write_browser;
  631. var
  632. oldrecsyms : psymtable;
  633. begin
  634. { symbol numbering for references
  635. should have been done in write PM
  636. number_symbols;
  637. number_defs; }
  638. if symtabletype in [recordsymtable,objectsymtable] then
  639. begin
  640. oldrecsyms:=aktrecordsymtable;
  641. aktrecordsymtable:=@self;
  642. end;
  643. if symtabletype in [parasymtable,localsymtable] then
  644. begin
  645. oldrecsyms:=aktlocalsymtable;
  646. aktlocalsymtable:=@self;
  647. end;
  648. current_ppu^.writeentry(ibbeginsymtablebrowser);
  649. foreach({$ifdef FPCPROCVAR}@{$endif}write_refs);
  650. current_ppu^.writeentry(ibendsymtablebrowser);
  651. if symtabletype in [recordsymtable,objectsymtable] then
  652. aktrecordsymtable:=oldrecsyms;
  653. if symtabletype in [parasymtable,localsymtable] then
  654. aktlocalsymtable:=oldrecsyms;
  655. end;
  656. {$ifdef GDB}
  657. function tstoredsymtable.getnewtypecount : word;
  658. begin
  659. getnewtypecount:=pglobaltypecount^;
  660. inc(pglobaltypecount^);
  661. end;
  662. {$endif GDB}
  663. procedure order_overloads(p : Pnamedindexobject);
  664. begin
  665. if psym(p)^.typ=procsym then
  666. pprocsym(p)^.order_overloaded;
  667. end;
  668. procedure tstoredsymtable.prederef;
  669. var
  670. hs : psym;
  671. begin
  672. { first deref the ttypesyms }
  673. hs:=psym(symindex^.first);
  674. while assigned(hs) do
  675. begin
  676. hs^.prederef;
  677. hs:=psym(hs^.indexnext);
  678. end;
  679. end;
  680. procedure tstoredsymtable.deref;
  681. var
  682. hp : pdef;
  683. hs : psym;
  684. begin
  685. { deref the definitions }
  686. hp:=pdef(defindex^.first);
  687. while assigned(hp) do
  688. begin
  689. hp^.deref;
  690. hp:=pdef(hp^.indexnext);
  691. end;
  692. { deref the symbols }
  693. hs:=psym(symindex^.first);
  694. while assigned(hs) do
  695. begin
  696. hs^.deref;
  697. hs:=psym(hs^.indexnext);
  698. end;
  699. end;
  700. { this procedure is reserved for inserting case variant into
  701. a record symtable }
  702. { the offset is the location of the start of the variant
  703. and datasize and dataalignment corresponds to
  704. the complete size (see code in pdecl unit) PM }
  705. procedure tstoredsymtable.insert_in(psymt : psymtable;offset : longint);
  706. var
  707. ps,nps : pvarsym;
  708. pd,npd : pdef;
  709. storesize,storealign : longint;
  710. begin
  711. storesize:=psymt^.datasize;
  712. storealign:=psymt^.dataalignment;
  713. psymt^.datasize:=offset;
  714. ps:=pvarsym(symindex^.first);
  715. while assigned(ps) do
  716. begin
  717. { this is used to insert case variant into the main
  718. record }
  719. psymt^.datasize:=ps^.address+offset;
  720. nps:=pvarsym(ps^.indexnext);
  721. symindex^.deleteindex(ps);
  722. ps^.indexnext:=nil;
  723. ps^.left:=nil;
  724. ps^.right:=nil;
  725. psymt^.insert(ps);
  726. ps:=nps;
  727. end;
  728. pd:=pdef(defindex^.first);
  729. while assigned(pd) do
  730. begin
  731. npd:=pdef(pd^.indexnext);
  732. defindex^.deleteindex(pd);
  733. pd^.indexnext:=nil;
  734. pd^.left:=nil;
  735. pd^.right:=nil;
  736. psymt^.registerdef(pd);
  737. pd:=npd;
  738. end;
  739. psymt^.datasize:=storesize;
  740. psymt^.dataalignment:=storealign;
  741. end;
  742. constructor tstoredsymtable.loadas(typ : tsymtabletype);
  743. var
  744. storesymtable : psymtable;
  745. st_loading : boolean;
  746. begin
  747. st_loading:=in_loading;
  748. in_loading:=true;
  749. symtabletype:=typ;
  750. new(symindex,init(indexgrowsize));
  751. new(defindex,init(indexgrowsize));
  752. new(symsearch,init);
  753. symsearch^.noclear:=true;
  754. { reset }
  755. defowner:=nil;
  756. name:=nil;
  757. if typ=parasymtable then
  758. dataalignment:=4
  759. else
  760. dataalignment:=1;
  761. datasize:=0;
  762. address_fixup:= 0;
  763. unitid:=0;
  764. { setup symtabletype specific things }
  765. case typ of
  766. unitsymtable :
  767. begin
  768. symtablelevel:=0;
  769. {$ifndef NEWMAP}
  770. current_module.map^[0]:=@self;
  771. {$else NEWMAP}
  772. current_module.globalsymtable:=@self;
  773. {$endif NEWMAP}
  774. end;
  775. recordsymtable,
  776. objectsymtable :
  777. begin
  778. storesymtable:=aktrecordsymtable;
  779. aktrecordsymtable:=@self;
  780. end;
  781. parasymtable,
  782. localsymtable :
  783. begin
  784. storesymtable:=aktlocalsymtable;
  785. aktlocalsymtable:=@self;
  786. end;
  787. { used for local browser }
  788. staticppusymtable :
  789. begin
  790. aktstaticsymtable:=@self;
  791. symsearch^.usehash;
  792. end;
  793. end;
  794. { we need the correct symtable for registering }
  795. if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then
  796. begin
  797. next:=symtablestack;
  798. symtablestack:=@self;
  799. end;
  800. { load definitions }
  801. loaddefs;
  802. { load symbols }
  803. loadsyms;
  804. if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then
  805. begin
  806. { now we can deref the syms and defs }
  807. prederef;
  808. { restore symtablestack }
  809. symtablestack:=next;
  810. end;
  811. case typ of
  812. unitsymtable :
  813. begin
  814. {$ifdef NEWMAP}
  815. { necessary for dependencies }
  816. current_module.globalsymtable:=nil;
  817. {$endif NEWMAP}
  818. end;
  819. recordsymtable,
  820. objectsymtable :
  821. aktrecordsymtable:=storesymtable;
  822. localsymtable,
  823. parasymtable :
  824. aktlocalsymtable:=storesymtable;
  825. end;
  826. in_loading:=st_loading;
  827. end;
  828. procedure tstoredsymtable.writeas;
  829. var
  830. oldtyp : byte;
  831. storesymtable : psymtable;
  832. begin
  833. storesymtable:=aktrecordsymtable;
  834. case symtabletype of
  835. recordsymtable,
  836. objectsymtable :
  837. begin
  838. storesymtable:=aktrecordsymtable;
  839. aktrecordsymtable:=@self;
  840. oldtyp:=current_ppu^.entrytyp;
  841. current_ppu^.entrytyp:=subentryid;
  842. end;
  843. parasymtable,
  844. localsymtable :
  845. begin
  846. storesymtable:=aktlocalsymtable;
  847. aktlocalsymtable:=@self;
  848. end;
  849. end;
  850. { order procsym overloads }
  851. foreach({$ifdef FPCPROCVAR}@{$endif}Order_overloads);
  852. { write definitions }
  853. writedefs;
  854. { write symbols }
  855. writesyms;
  856. case symtabletype of
  857. recordsymtable,
  858. objectsymtable :
  859. begin
  860. current_ppu^.entrytyp:=oldtyp;
  861. aktrecordsymtable:=storesymtable;
  862. end;
  863. localsymtable,
  864. parasymtable :
  865. aktlocalsymtable:=storesymtable;
  866. end;
  867. end;
  868. procedure tstoredsymtable.insert(sym:psymentry);
  869. var
  870. hp : psymtable;
  871. hsym : psym;
  872. begin
  873. { set owner and sym indexnb }
  874. sym^.owner:=@self;
  875. {$ifdef CHAINPROCSYMS}
  876. { set the nextprocsym field }
  877. if sym^.typ=procsym then
  878. chainprocsym(sym);
  879. {$endif CHAINPROCSYMS}
  880. { writes the symbol in data segment if required }
  881. { also sets the datasize of owner }
  882. if not in_loading then
  883. pstoredsym(sym)^.insert_in_data;
  884. if (symtabletype in [staticsymtable,globalsymtable]) then
  885. begin
  886. hp:=symtablestack;
  887. while assigned(hp) do
  888. begin
  889. if hp^.symtabletype in [staticsymtable,globalsymtable] then
  890. begin
  891. hsym:=psym(hp^.search(sym^.name));
  892. if assigned(hsym) then
  893. DuplicateSym(hsym);
  894. end;
  895. hp:=hp^.next;
  896. end;
  897. end;
  898. { check the current symtable }
  899. hsym:=psym(search(sym^.name));
  900. if assigned(hsym) then
  901. begin
  902. { in TP and Delphi you can have a local with the
  903. same name as the function, the function is then hidden for
  904. the user. (Under delphi it can still be accessed using result),
  905. but don't allow hiding of RESULT }
  906. if (m_tp in aktmodeswitches) and
  907. (hsym^.typ=funcretsym) and
  908. not((m_result in aktmodeswitches) and
  909. (hsym^.name='RESULT')) then
  910. hsym^.owner^.rename(hsym^.name,'hidden'+hsym^.name)
  911. else
  912. begin
  913. DuplicateSym(hsym);
  914. exit;
  915. end;
  916. end;
  917. { check for duplicate id in local and parasymtable symtable }
  918. if (symtabletype=localsymtable) then
  919. { to be on the save side: }
  920. begin
  921. if assigned(next) and
  922. (next^.symtabletype=parasymtable) then
  923. begin
  924. hsym:=psym(next^.search(sym^.name));
  925. if assigned(hsym) then
  926. begin
  927. { a parameter and the function can have the same
  928. name in TP and Delphi, but RESULT not }
  929. if (m_tp in aktmodeswitches) and
  930. (sym^.typ=funcretsym) and
  931. not((m_result in aktmodeswitches) and
  932. (sym^.name='RESULT')) then
  933. sym^.setname('hidden'+sym^.name)
  934. else
  935. begin
  936. DuplicateSym(hsym);
  937. exit;
  938. end;
  939. end;
  940. end
  941. else if (current_module.flags and uf_local_browser)=0 then
  942. internalerror(43789);
  943. end;
  944. { check for duplicate id in local symtable of methods }
  945. if (symtabletype=localsymtable) and
  946. assigned(next) and
  947. assigned(next^.next) and
  948. { funcretsym is allowed !! }
  949. (sym^.typ <> funcretsym) and
  950. (next^.next^.symtabletype=objectsymtable) then
  951. begin
  952. hsym:=search_class_member(pobjectdef(next^.next^.defowner),sym^.name);
  953. if assigned(hsym) and
  954. { private ids can be reused }
  955. (not(sp_private in hsym^.symoptions) or
  956. (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
  957. begin
  958. { delphi allows to reuse the names in a class, but not
  959. in object (tp7 compatible) }
  960. if not((m_delphi in aktmodeswitches) and
  961. is_class(pdef(next^.next^.defowner))) then
  962. begin
  963. DuplicateSym(hsym);
  964. exit;
  965. end;
  966. end;
  967. end;
  968. { check for duplicate id in para symtable of methods }
  969. if (symtabletype=parasymtable) and
  970. assigned(procinfo^._class) and
  971. { but not in nested procedures !}
  972. (not(assigned(procinfo^.parent)) or
  973. (assigned(procinfo^.parent) and
  974. not(assigned(procinfo^.parent^._class)))
  975. ) and
  976. { funcretsym is allowed !! }
  977. (sym^.typ <> funcretsym) then
  978. begin
  979. hsym:=search_class_member(procinfo^._class,sym^.name);
  980. if assigned(hsym) and
  981. { private ids can be reused }
  982. (not(sp_private in hsym^.symoptions) or
  983. (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
  984. begin
  985. { delphi allows to reuse the names in a class, but not
  986. in object (tp7 compatible) }
  987. if not((m_delphi in aktmodeswitches) and
  988. is_class(procinfo^._class)) then
  989. begin
  990. DuplicateSym(hsym);
  991. exit;
  992. end;
  993. end;
  994. end;
  995. { check for duplicate field id in inherited classes }
  996. if (sym^.typ=varsym) and
  997. (symtabletype=objectsymtable) and
  998. assigned(defowner) and
  999. (
  1000. not(m_delphi in aktmodeswitches) or
  1001. is_object(pdef(defowner))
  1002. ) then
  1003. begin
  1004. { but private ids can be reused }
  1005. hsym:=search_class_member(pobjectdef(defowner),sym^.name);
  1006. if assigned(hsym) and
  1007. (not(sp_private in hsym^.symoptions) or
  1008. (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
  1009. begin
  1010. DuplicateSym(hsym);
  1011. exit;
  1012. end;
  1013. end;
  1014. { register definition of typesym }
  1015. if (sym^.typ = typesym) and
  1016. assigned(ptypesym(sym)^.restype.def) then
  1017. begin
  1018. if not(assigned(ptypesym(sym)^.restype.def^.owner)) and
  1019. (ptypesym(sym)^.restype.def^.deftype<>errordef) then
  1020. registerdef(ptypesym(sym)^.restype.def);
  1021. {$ifdef GDB}
  1022. if (cs_debuginfo in aktmoduleswitches) and assigned(debuglist) and
  1023. (symtabletype in [globalsymtable,staticsymtable]) then
  1024. begin
  1025. ptypesym(sym)^.isusedinstab := true;
  1026. {sym^.concatstabto(debuglist);}
  1027. end;
  1028. {$endif GDB}
  1029. end;
  1030. { insert in index and search hash }
  1031. symindex^.insert(sym);
  1032. symsearch^.insert(sym);
  1033. end;
  1034. function tstoredsymtable.speedsearch(const s : stringid;speedvalue : longint) : psymentry;
  1035. var
  1036. hp : pstoredsym;
  1037. newref : pref;
  1038. begin
  1039. hp:=pstoredsym(inherited speedsearch(s,speedvalue));
  1040. if assigned(hp) then
  1041. begin
  1042. { reject non static members in static procedures,
  1043. be carefull aktprocsym^.definition is not allways
  1044. loaded already (PFV) }
  1045. if (symtabletype=objectsymtable) and
  1046. not(sp_static in hp^.symoptions) and
  1047. allow_only_static
  1048. {assigned(aktprocsym) and
  1049. assigned(aktprocsym^.definition) and
  1050. ((aktprocsym^.definition^.options and postaticmethod)<>0)} then
  1051. Message(sym_e_only_static_in_static);
  1052. if (symtabletype=unitsymtable) and
  1053. assigned(punitsymtable(@self)^.unitsym) then
  1054. inc(punitsymtable(@self)^.unitsym^.refs);
  1055. {$ifdef GDB}
  1056. { if it is a type, we need the stabs of this type
  1057. this might be the cause of the class debug problems
  1058. as TCHILDCLASS.Create did not generate appropriate
  1059. stabs debug info if TCHILDCLASS wasn't used anywhere else PM }
  1060. if (hp^.typ=typesym) and make_ref then
  1061. begin
  1062. if assigned(ptypesym(hp)^.restype.def) then
  1063. pstoreddef(ptypesym(hp)^.restype.def)^.numberstring
  1064. else
  1065. ptypesym(hp)^.isusedinstab:=true;
  1066. end;
  1067. {$endif GDB}
  1068. { unitsym are only loaded for browsing PM }
  1069. { this was buggy anyway because we could use }
  1070. { unitsyms from other units in _USES !! }
  1071. {if (symtabletype=unitsymtable) and (hp^.typ=unitsym) and
  1072. assigned(current_module) and (current_module.globalsymtable<>@self) then
  1073. hp:=nil;}
  1074. if assigned(hp) and
  1075. (cs_browser in aktmoduleswitches) and make_ref then
  1076. begin
  1077. new(newref,init(hp^.lastref,@akttokenpos));
  1078. { for symbols that are in tables without
  1079. browser info or syssyms (PM) }
  1080. if hp^.refcount=0 then
  1081. begin
  1082. hp^.defref:=newref;
  1083. hp^.lastref:=newref;
  1084. end
  1085. else
  1086. if resolving_forward and assigned(hp^.defref) then
  1087. { put it as second reference }
  1088. begin
  1089. newref^.nextref:=hp^.defref^.nextref;
  1090. hp^.defref^.nextref:=newref;
  1091. hp^.lastref^.nextref:=nil;
  1092. end
  1093. else
  1094. hp^.lastref:=newref;
  1095. inc(hp^.refcount);
  1096. end;
  1097. if assigned(hp) and make_ref then
  1098. begin
  1099. inc(hp^.refs);
  1100. end;
  1101. end;
  1102. speedsearch:=hp;
  1103. end;
  1104. {***********************************************
  1105. Process all entries
  1106. ***********************************************}
  1107. { checks, if all procsyms and methods are defined }
  1108. procedure tstoredsymtable.check_forwards;
  1109. begin
  1110. foreach({$ifdef FPCPROCVAR}@{$endif}check_forward);
  1111. end;
  1112. procedure tstoredsymtable.checklabels;
  1113. begin
  1114. foreach({$ifdef FPCPROCVAR}@{$endif}labeldefined);
  1115. end;
  1116. procedure tstoredsymtable.set_alignment(_alignment : longint);
  1117. var
  1118. sym : pvarsym;
  1119. l : longint;
  1120. begin
  1121. dataalignment:=_alignment;
  1122. if (symtabletype<>parasymtable) then
  1123. internalerror(1111);
  1124. sym:=pvarsym(symindex^.first);
  1125. datasize:=0;
  1126. { there can be only varsyms }
  1127. while assigned(sym) do
  1128. begin
  1129. l:=sym^.getpushsize;
  1130. sym^.address:=datasize;
  1131. datasize:=align(datasize+l,dataalignment);
  1132. sym:=pvarsym(sym^.indexnext);
  1133. end;
  1134. end;
  1135. procedure tstoredsymtable.allunitsused;
  1136. begin
  1137. foreach({$ifdef FPCPROCVAR}@{$endif}unitsymbolused);
  1138. end;
  1139. procedure tstoredsymtable.allsymbolsused;
  1140. begin
  1141. foreach({$ifdef FPCPROCVAR}@{$endif}varsymbolused);
  1142. end;
  1143. procedure tstoredsymtable.allprivatesused;
  1144. begin
  1145. foreach({$ifdef FPCPROCVAR}@{$endif}objectprivatesymbolused);
  1146. end;
  1147. {$ifdef CHAINPROCSYMS}
  1148. procedure tstoredsymtable.chainprocsyms;
  1149. begin
  1150. foreach({$ifdef FPCPROCVAR}@{$endif}chainprocsym);
  1151. end;
  1152. {$endif CHAINPROCSYMS}
  1153. {$ifdef GDB}
  1154. procedure tstoredsymtable.concatstabto(asmlist : taasmoutput);
  1155. begin
  1156. asmoutput:=asmlist;
  1157. if symtabletype in [inlineparasymtable,inlinelocalsymtable] then
  1158. foreach({$ifdef FPCPROCVAR}@{$endif}resetstab);
  1159. foreach({$ifdef FPCPROCVAR}@{$endif}concatstab);
  1160. end;
  1161. {$endif}
  1162. {****************************************************************************
  1163. TWITHSYMTABLE
  1164. ****************************************************************************}
  1165. constructor twithsymtable.init;
  1166. begin
  1167. inherited init(withsymtable);
  1168. direct_with:=false;
  1169. withnode:=nil;
  1170. withrefnode:=nil;
  1171. { we don't need the symsearch }
  1172. dispose(symsearch,done);
  1173. symsearch:=nil;
  1174. end;
  1175. destructor twithsymtable.done;
  1176. begin
  1177. symsearch:=nil;
  1178. inherited done;
  1179. end;
  1180. procedure twithsymtable.clear;
  1181. begin
  1182. { remove no entry from a withsymtable as it is only a pointer to the
  1183. recorddef or objectdef symtable }
  1184. end;
  1185. {****************************************************************************
  1186. PPU Writing Helpers
  1187. ****************************************************************************}
  1188. procedure writesourcefiles;
  1189. var
  1190. hp : tinputfile;
  1191. i,j : longint;
  1192. begin
  1193. { second write the used source files }
  1194. current_ppu^.do_crc:=false;
  1195. hp:=current_module.sourcefiles.files;
  1196. { write source files directly in good order }
  1197. j:=0;
  1198. while assigned(hp) do
  1199. begin
  1200. inc(j);
  1201. hp:=hp.ref_next;
  1202. end;
  1203. while j>0 do
  1204. begin
  1205. hp:=current_module.sourcefiles.files;
  1206. for i:=1 to j-1 do
  1207. hp:=hp.ref_next;
  1208. current_ppu^.putstring(hp.name^);
  1209. dec(j);
  1210. end;
  1211. current_ppu^.writeentry(ibsourcefiles);
  1212. current_ppu^.do_crc:=true;
  1213. end;
  1214. procedure writeusedmacro(p:pnamedindexobject);
  1215. begin
  1216. if pmacro(p)^.is_used or pmacro(p)^.defined_at_startup then
  1217. begin
  1218. current_ppu^.putstring(p^.name);
  1219. current_ppu^.putbyte(byte(pmacro(p)^.defined_at_startup));
  1220. current_ppu^.putbyte(byte(pmacro(p)^.is_used));
  1221. end;
  1222. end;
  1223. procedure writeusedmacros;
  1224. begin
  1225. current_ppu^.do_crc:=false;
  1226. current_scanner^.macros^.foreach({$ifdef FPCPROCVAR}@{$endif}writeusedmacro);
  1227. current_ppu^.writeentry(ibusedmacros);
  1228. current_ppu^.do_crc:=true;
  1229. end;
  1230. procedure writeusedunit;
  1231. var
  1232. hp : tused_unit;
  1233. begin
  1234. numberunits;
  1235. hp:=tused_unit(current_module.used_units.first);
  1236. while assigned(hp) do
  1237. begin
  1238. { implementation units should not change
  1239. the CRC PM }
  1240. current_ppu^.do_crc:=hp.in_interface;
  1241. current_ppu^.putstring(hp.name^);
  1242. { the checksum should not affect the crc of this unit ! (PFV) }
  1243. current_ppu^.do_crc:=false;
  1244. current_ppu^.putlongint(hp.checksum);
  1245. current_ppu^.putlongint(hp.interface_checksum);
  1246. current_ppu^.putbyte(byte(hp.in_interface));
  1247. current_ppu^.do_crc:=true;
  1248. hp:=tused_unit(hp.next);
  1249. end;
  1250. current_ppu^.do_interface_crc:=true;
  1251. current_ppu^.writeentry(ibloadunit);
  1252. end;
  1253. procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
  1254. var
  1255. hcontainer : tlinkcontainer;
  1256. s : string;
  1257. mask : longint;
  1258. begin
  1259. hcontainer:=TLinkContainer.Create;
  1260. while not p.empty do
  1261. begin
  1262. s:=p.get(mask);
  1263. if strippath then
  1264. current_ppu^.putstring(SplitFileName(s))
  1265. else
  1266. current_ppu^.putstring(s);
  1267. current_ppu^.putlongint(mask);
  1268. hcontainer.add(s,mask);
  1269. end;
  1270. current_ppu^.writeentry(id);
  1271. p.Free;
  1272. p:=hcontainer;
  1273. end;
  1274. procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
  1275. begin
  1276. Message1(unit_u_ppu_write,s);
  1277. { create unit flags }
  1278. with Current_Module do
  1279. begin
  1280. {$ifdef GDB}
  1281. if cs_gdb_dbx in aktglobalswitches then
  1282. flags:=flags or uf_has_dbx;
  1283. {$endif GDB}
  1284. if target_os.endian=endian_big then
  1285. flags:=flags or uf_big_endian;
  1286. if cs_browser in aktmoduleswitches then
  1287. flags:=flags or uf_has_browser;
  1288. if cs_local_browser in aktmoduleswitches then
  1289. flags:=flags or uf_local_browser;
  1290. end;
  1291. {$ifdef Test_Double_checksum_write}
  1292. If only_crc then
  1293. Assign(CRCFile,s+'.INT')
  1294. else
  1295. Assign(CRCFile,s+'.IMP');
  1296. Rewrite(CRCFile);
  1297. {$endif def Test_Double_checksum_write}
  1298. { open ppufile }
  1299. current_ppu:=new(pppufile,init(s));
  1300. current_ppu^.crc_only:=only_crc;
  1301. if not current_ppu^.create then
  1302. Message(unit_f_ppu_cannot_write);
  1303. {$ifdef Test_Double_checksum}
  1304. if only_crc then
  1305. begin
  1306. new(current_ppu^.crc_test);
  1307. new(current_ppu^.crc_test2);
  1308. end
  1309. else
  1310. begin
  1311. current_ppu^.crc_test:=current_module.crc_array;
  1312. current_ppu^.crc_index:=current_module.crc_size;
  1313. current_ppu^.crc_test2:=current_module.crc_array2;
  1314. current_ppu^.crc_index2:=current_module.crc_size2;
  1315. end;
  1316. {$endif def Test_Double_checksum}
  1317. current_ppu^.change_endian:=source_os.endian<>target_os.endian;
  1318. { write symbols and definitions }
  1319. unittable^.writeasunit;
  1320. { flush to be sure }
  1321. current_ppu^.flush;
  1322. { create and write header }
  1323. current_ppu^.header.size:=current_ppu^.size;
  1324. current_ppu^.header.checksum:=current_ppu^.crc;
  1325. current_ppu^.header.interface_checksum:=current_ppu^.interface_crc;
  1326. current_ppu^.header.compiler:=wordversion;
  1327. current_ppu^.header.cpu:=word(target_cpu);
  1328. current_ppu^.header.target:=word(target_info.target);
  1329. current_ppu^.header.flags:=current_module.flags;
  1330. If not only_crc then
  1331. current_ppu^.writeheader;
  1332. { save crc in current_module also }
  1333. current_module.crc:=current_ppu^.crc;
  1334. current_module.interface_crc:=current_ppu^.interface_crc;
  1335. if only_crc then
  1336. begin
  1337. {$ifdef Test_Double_checksum}
  1338. current_module.crc_array:=current_ppu^.crc_test;
  1339. current_ppu^.crc_test:=nil;
  1340. current_module.crc_size:=current_ppu^.crc_index2;
  1341. current_module.crc_array2:=current_ppu^.crc_test2;
  1342. current_ppu^.crc_test2:=nil;
  1343. current_module.crc_size2:=current_ppu^.crc_index2;
  1344. {$endif def Test_Double_checksum}
  1345. closecurrentppu;
  1346. end;
  1347. {$ifdef Test_Double_checksum_write}
  1348. close(CRCFile);
  1349. {$endif Test_Double_checksum_write}
  1350. end;
  1351. procedure readusedmacros;
  1352. var
  1353. hs : string;
  1354. mac : pmacro;
  1355. was_defined_at_startup,
  1356. was_used : boolean;
  1357. begin
  1358. while not current_ppu^.endofentry do
  1359. begin
  1360. hs:=current_ppu^.getstring;
  1361. was_defined_at_startup:=boolean(current_ppu^.getbyte);
  1362. was_used:=boolean(current_ppu^.getbyte);
  1363. mac:=pmacro(current_scanner^.macros^.search(hs));
  1364. if assigned(mac) then
  1365. begin
  1366. {$ifndef EXTDEBUG}
  1367. { if we don't have the sources why tell }
  1368. if current_module.sources_avail then
  1369. {$endif ndef EXTDEBUG}
  1370. if (not was_defined_at_startup) and
  1371. was_used and
  1372. mac^.defined_at_startup then
  1373. Message2(unit_h_cond_not_set_in_last_compile,hs,current_module.mainsource^);
  1374. end
  1375. else { not assigned }
  1376. if was_defined_at_startup and
  1377. was_used then
  1378. Message2(unit_h_cond_not_set_in_last_compile,hs,current_module.mainsource^);
  1379. end;
  1380. end;
  1381. procedure readsourcefiles;
  1382. var
  1383. temp,hs : string;
  1384. temp_dir : string;
  1385. main_dir : string;
  1386. incfile_found,
  1387. main_found,
  1388. is_main : boolean;
  1389. ppufiletime,
  1390. source_time : longint;
  1391. hp : tinputfile;
  1392. begin
  1393. ppufiletime:=getnamedfiletime(current_module.ppufilename^);
  1394. current_module.sources_avail:=true;
  1395. is_main:=true;
  1396. main_dir:='';
  1397. while not current_ppu^.endofentry do
  1398. begin
  1399. hs:=current_ppu^.getstring;
  1400. temp_dir:='';
  1401. if (current_module.flags and uf_in_library)<>0 then
  1402. begin
  1403. current_module.sources_avail:=false;
  1404. temp:=' library';
  1405. end
  1406. else if pos('Macro ',hs)=1 then
  1407. begin
  1408. { we don't want to find this file }
  1409. { but there is a problem with file indexing !! }
  1410. temp:='';
  1411. end
  1412. else
  1413. begin
  1414. { check the date of the source files }
  1415. Source_Time:=GetNamedFileTime(current_module.path^+hs);
  1416. incfile_found:=false;
  1417. main_found:=false;
  1418. if Source_Time<>-1 then
  1419. hs:=current_module.path^+hs
  1420. else
  1421. if not(is_main) then
  1422. begin
  1423. Source_Time:=GetNamedFileTime(main_dir+hs);
  1424. if Source_Time<>-1 then
  1425. hs:=main_dir+hs;
  1426. end;
  1427. if (Source_Time=-1) then
  1428. begin
  1429. if is_main then
  1430. main_found:=unitsearchpath.FindFile(hs,temp_dir)
  1431. else
  1432. incfile_found:=includesearchpath.FindFile(hs,temp_dir);
  1433. if incfile_found or main_found then
  1434. Source_Time:=GetNamedFileTime(temp_dir);
  1435. end;
  1436. if Source_Time=-1 then
  1437. begin
  1438. current_module.sources_avail:=false;
  1439. temp:=' not found';
  1440. end
  1441. else
  1442. begin
  1443. if main_found then
  1444. main_dir:=temp_dir;
  1445. { time newer? But only allow if the file is not searched
  1446. in the include path (PFV), else you've problems with
  1447. units which use the same includefile names }
  1448. if incfile_found then
  1449. temp:=' found'
  1450. else
  1451. begin
  1452. temp:=' time '+filetimestring(source_time);
  1453. if (source_time>ppufiletime) then
  1454. begin
  1455. current_module.do_compile:=true;
  1456. current_module.recompile_reason:=rr_sourcenewer;
  1457. temp:=temp+' *'
  1458. end;
  1459. end;
  1460. end;
  1461. hp:=tinputfile.create(hs);
  1462. { the indexing is wrong here PM }
  1463. current_module.sourcefiles.register_file(hp);
  1464. end;
  1465. if is_main then
  1466. begin
  1467. stringdispose(current_module.mainsource);
  1468. current_module.mainsource:=stringdup(hs);
  1469. end;
  1470. Message1(unit_u_ppu_source,hs+temp);
  1471. is_main:=false;
  1472. end;
  1473. { check if we want to rebuild every unit, only if the sources are
  1474. available }
  1475. if do_build and current_module.sources_avail then
  1476. begin
  1477. current_module.do_compile:=true;
  1478. current_module.recompile_reason:=rr_build;
  1479. end;
  1480. end;
  1481. procedure readloadunit;
  1482. var
  1483. hs : string;
  1484. intfchecksum,
  1485. checksum : longint;
  1486. in_interface : boolean;
  1487. begin
  1488. while not current_ppu^.endofentry do
  1489. begin
  1490. hs:=current_ppu^.getstring;
  1491. checksum:=current_ppu^.getlongint;
  1492. intfchecksum:=current_ppu^.getlongint;
  1493. in_interface:=(current_ppu^.getbyte<>0);
  1494. current_module.used_units.concat(tused_unit.create_to_load(hs,checksum,intfchecksum,in_interface));
  1495. end;
  1496. end;
  1497. procedure readlinkcontainer(var p:tlinkcontainer);
  1498. var
  1499. s : string;
  1500. m : longint;
  1501. begin
  1502. while not current_ppu^.endofentry do
  1503. begin
  1504. s:=current_ppu^.getstring;
  1505. m:=current_ppu^.getlongint;
  1506. p.add(s,m);
  1507. end;
  1508. end;
  1509. procedure load_interface;
  1510. var
  1511. b : byte;
  1512. newmodulename : string;
  1513. begin
  1514. { read interface part }
  1515. repeat
  1516. b:=current_ppu^.readentry;
  1517. case b of
  1518. ibmodulename :
  1519. begin
  1520. newmodulename:=current_ppu^.getstring;
  1521. if upper(newmodulename)<>current_module.modulename^ then
  1522. Message2(unit_f_unit_name_error,current_module.realmodulename^,newmodulename);
  1523. stringdispose(current_module.modulename);
  1524. stringdispose(current_module.realmodulename);
  1525. current_module.modulename:=stringdup(upper(newmodulename));
  1526. current_module.realmodulename:=stringdup(newmodulename);
  1527. end;
  1528. ibsourcefiles :
  1529. readsourcefiles;
  1530. ibusedmacros :
  1531. readusedmacros;
  1532. ibloadunit :
  1533. readloadunit;
  1534. iblinkunitofiles :
  1535. readlinkcontainer(current_module.LinkUnitOFiles);
  1536. iblinkunitstaticlibs :
  1537. readlinkcontainer(current_module.LinkUnitStaticLibs);
  1538. iblinkunitsharedlibs :
  1539. readlinkcontainer(current_module.LinkUnitSharedLibs);
  1540. iblinkotherofiles :
  1541. readlinkcontainer(current_module.LinkotherOFiles);
  1542. iblinkotherstaticlibs :
  1543. readlinkcontainer(current_module.LinkotherStaticLibs);
  1544. iblinkothersharedlibs :
  1545. readlinkcontainer(current_module.LinkotherSharedLibs);
  1546. ibendinterface :
  1547. break;
  1548. else
  1549. Message1(unit_f_ppu_invalid_entry,tostr(b));
  1550. end;
  1551. until false;
  1552. end;
  1553. {****************************************************************************
  1554. TUNITSYMTABLE
  1555. ****************************************************************************}
  1556. constructor tunitsymtable.init(t : tsymtabletype; const n : string);
  1557. begin
  1558. inherited init(t);
  1559. name:=stringdup(upper(n));
  1560. unitid:=0;
  1561. unitsym:=nil;
  1562. symsearch^.usehash;
  1563. { reset GDB things }
  1564. {$ifdef GDB}
  1565. if (t = globalsymtable) then
  1566. begin
  1567. prev_dbx_counter := dbx_counter;
  1568. dbx_counter := nil;
  1569. end;
  1570. is_stab_written:=false;
  1571. dbx_count := -1;
  1572. if cs_gdb_dbx in aktglobalswitches then
  1573. begin
  1574. dbx_count := 0;
  1575. unittypecount:=1;
  1576. if (symtabletype=globalsymtable) then
  1577. pglobaltypecount := @unittypecount;
  1578. unitid:=current_module.unitcount;
  1579. debugList.concat(Tai_asm_comment.Create(strpnew('Global '+name^+' has index '+tostr(unitid))));
  1580. debugList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
  1581. inc(current_module.unitcount);
  1582. dbx_count_ok:=false;
  1583. dbx_counter:=@dbx_count;
  1584. do_count_dbx:=true;
  1585. end;
  1586. {$endif GDB}
  1587. end;
  1588. constructor tunitsymtable.loadasunit;
  1589. var
  1590. {$ifdef GDB}
  1591. storeGlobalTypeCount : pword;
  1592. {$endif GDB}
  1593. b : byte;
  1594. begin
  1595. unitsym:=nil;
  1596. unitid:=0;
  1597. {$ifdef GDB}
  1598. if cs_gdb_dbx in aktglobalswitches then
  1599. begin
  1600. UnitTypeCount:=1;
  1601. storeGlobalTypeCount:=PGlobalTypeCount;
  1602. PglobalTypeCount:=@UnitTypeCount;
  1603. end;
  1604. {$endif GDB}
  1605. { load symtables }
  1606. inherited loadas(unitsymtable);
  1607. { set the name after because it is set to nil in tstoredsymtable.load !! }
  1608. name:=stringdup(current_module.modulename^);
  1609. { dbx count }
  1610. {$ifdef GDB}
  1611. if (current_module.flags and uf_has_dbx)<>0 then
  1612. begin
  1613. b := current_ppu^.readentry;
  1614. if b <> ibdbxcount then
  1615. Message(unit_f_ppu_dbx_count_problem)
  1616. else
  1617. dbx_count := readlong;
  1618. dbx_count_ok := {true}false;
  1619. end
  1620. else
  1621. begin
  1622. dbx_count := -1;
  1623. dbx_count_ok:=false;
  1624. end;
  1625. if cs_gdb_dbx in aktglobalswitches then
  1626. PGlobalTypeCount:=storeGlobalTypeCount;
  1627. is_stab_written:=false;
  1628. {$endif GDB}
  1629. b:=current_ppu^.readentry;
  1630. if b<>ibendimplementation then
  1631. Message1(unit_f_ppu_invalid_entry,tostr(b));
  1632. end;
  1633. destructor tunitsymtable.done;
  1634. var
  1635. pus : punitsym;
  1636. begin
  1637. pus:=unitsym;
  1638. while assigned(pus) do
  1639. begin
  1640. unitsym:=pus^.prevsym;
  1641. pus^.prevsym:=nil;
  1642. pus^.unitsymtable:=nil;
  1643. pus:=unitsym;
  1644. end;
  1645. inherited done;
  1646. end;
  1647. procedure tunitsymtable.load_symtable_refs;
  1648. var
  1649. b : byte;
  1650. unitindex : word;
  1651. begin
  1652. if ((current_module.flags and uf_local_browser)<>0) then
  1653. begin
  1654. current_module.localsymtable:=new(punitsymtable,loadas(staticppusymtable));
  1655. psymtable(current_module.localsymtable)^.name:=
  1656. stringdup('implementation of '+psymtable(current_module.globalsymtable)^.name^);
  1657. end;
  1658. { load browser }
  1659. if (current_module.flags and uf_has_browser)<>0 then
  1660. begin
  1661. {if not (cs_browser in aktmoduleswitches) then
  1662. current_ppu^.skipuntilentry(ibendbrowser)
  1663. else }
  1664. begin
  1665. load_browser;
  1666. unitindex:=1;
  1667. while assigned(current_module.map^[unitindex]) do
  1668. begin
  1669. {each unit wrote one browser entry }
  1670. load_browser;
  1671. inc(unitindex);
  1672. end;
  1673. b:=current_ppu^.readentry;
  1674. if b<>ibendbrowser then
  1675. Message1(unit_f_ppu_invalid_entry,tostr(b));
  1676. end;
  1677. end;
  1678. if ((current_module.flags and uf_local_browser)<>0) then
  1679. pstoredsymtable(current_module.localsymtable)^.load_browser;
  1680. end;
  1681. procedure tunitsymtable.writeasunit;
  1682. var
  1683. pu : tused_unit;
  1684. begin
  1685. { first the unitname }
  1686. current_ppu^.putstring(current_module.realmodulename^);
  1687. current_ppu^.writeentry(ibmodulename);
  1688. writesourcefiles;
  1689. writeusedmacros;
  1690. writeusedunit;
  1691. { write the objectfiles and libraries that come for this unit,
  1692. preserve the containers becuase they are still needed to load
  1693. the link.res. All doesn't depend on the crc! It doesn't matter
  1694. if a unit is in a .o or .a file }
  1695. current_ppu^.do_crc:=false;
  1696. writelinkcontainer(current_module.linkunitofiles,iblinkunitofiles,true);
  1697. writelinkcontainer(current_module.linkunitstaticlibs,iblinkunitstaticlibs,true);
  1698. writelinkcontainer(current_module.linkunitsharedlibs,iblinkunitsharedlibs,true);
  1699. writelinkcontainer(current_module.linkotherofiles,iblinkotherofiles,false);
  1700. writelinkcontainer(current_module.linkotherstaticlibs,iblinkotherstaticlibs,true);
  1701. writelinkcontainer(current_module.linkothersharedlibs,iblinkothersharedlibs,true);
  1702. current_ppu^.do_crc:=true;
  1703. current_ppu^.writeentry(ibendinterface);
  1704. { write the symtable entries }
  1705. inherited writeas;
  1706. { all after doesn't affect crc }
  1707. current_ppu^.do_crc:=false;
  1708. { write dbx count }
  1709. {$ifdef GDB}
  1710. if cs_gdb_dbx in aktglobalswitches then
  1711. begin
  1712. {$IfDef EXTDEBUG}
  1713. writeln('Writing dbx_count ',dbx_count,' in unit ',name^,'.ppu');
  1714. {$ENDIF EXTDEBUG}
  1715. current_ppu^.putlongint(dbx_count);
  1716. current_ppu^.writeentry(ibdbxcount);
  1717. end;
  1718. {$endif GDB}
  1719. current_ppu^.writeentry(ibendimplementation);
  1720. { write static symtable
  1721. needed for local debugging of unit functions }
  1722. if ((current_module.flags and uf_local_browser)<>0) and
  1723. assigned(current_module.localsymtable) then
  1724. pstoredsymtable(current_module.localsymtable)^.writeas;
  1725. { write all browser section }
  1726. if (current_module.flags and uf_has_browser)<>0 then
  1727. begin
  1728. write_browser;
  1729. pu:=tused_unit(current_module.used_units.first);
  1730. while assigned(pu) do
  1731. begin
  1732. pstoredsymtable(pu.u.globalsymtable)^.write_browser;
  1733. pu:=tused_unit(pu.next);
  1734. end;
  1735. current_ppu^.writeentry(ibendbrowser);
  1736. end;
  1737. if ((current_module.flags and uf_local_browser)<>0) and
  1738. assigned(current_module.localsymtable) then
  1739. pstoredsymtable(current_module.localsymtable)^.write_browser;
  1740. { the last entry ibend is written automaticly }
  1741. end;
  1742. {$ifdef GDB}
  1743. function tunitsymtable.getnewtypecount : word;
  1744. begin
  1745. if not (cs_gdb_dbx in aktglobalswitches) then
  1746. getnewtypecount:=tsymtable.getnewtypecount
  1747. else
  1748. if symtabletype = staticsymtable then
  1749. getnewtypecount:=tsymtable.getnewtypecount
  1750. else
  1751. begin
  1752. getnewtypecount:=unittypecount;
  1753. inc(unittypecount);
  1754. end;
  1755. end;
  1756. procedure tunitsymtable.concattypestabto(asmlist : taasmoutput);
  1757. var prev_dbx_count : plongint;
  1758. begin
  1759. if is_stab_written then exit;
  1760. if not assigned(name) then name := stringdup('Main_program');
  1761. if (symtabletype = unitsymtable) and
  1762. (current_module.globalsymtable<>@Self) then
  1763. begin
  1764. unitid:=current_module.unitcount;
  1765. inc(current_module.unitcount);
  1766. end;
  1767. asmList.concat(Tai_asm_comment.Create(strpnew('Begin unit '+name^
  1768. +' has index '+tostr(unitid))));
  1769. if cs_gdb_dbx in aktglobalswitches then
  1770. begin
  1771. if dbx_count_ok then
  1772. begin
  1773. asmList.concat(Tai_asm_comment.Create(strpnew('"repeated" unit '+name^
  1774. +' has index '+tostr(unitid)+' dbx count = '+tostr(dbx_count))));
  1775. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1776. +tostr(N_EXCL)+',0,0,'+tostr(dbx_count))));
  1777. exit;
  1778. end
  1779. else if (current_module.globalsymtable<>@Self) then
  1780. begin
  1781. prev_dbx_count := dbx_counter;
  1782. dbx_counter := nil;
  1783. do_count_dbx:=false;
  1784. if symtabletype = unitsymtable then
  1785. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
  1786. dbx_counter := @dbx_count;
  1787. dbx_count:=0;
  1788. do_count_dbx:=assigned(dbx_counter);
  1789. end;
  1790. end;
  1791. asmoutput:=asmlist;
  1792. foreach({$ifdef FPCPROCVAR}@{$endif}concattypestab);
  1793. if cs_gdb_dbx in aktglobalswitches then
  1794. begin
  1795. if (current_module.globalsymtable<>@Self) then
  1796. begin
  1797. dbx_counter := prev_dbx_count;
  1798. do_count_dbx:=false;
  1799. asmList.concat(Tai_asm_comment.Create(strpnew('End unit '+name^
  1800. +' has index '+tostr(unitid))));
  1801. asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
  1802. +tostr(N_EINCL)+',0,0,0')));
  1803. do_count_dbx:=assigned(dbx_counter);
  1804. dbx_count_ok := {true}false;
  1805. end;
  1806. end;
  1807. is_stab_written:=true;
  1808. end;
  1809. {$endif}
  1810. {*****************************************************************************
  1811. Helper Routines
  1812. *****************************************************************************}
  1813. procedure numberunits;
  1814. var
  1815. counter : longint;
  1816. hp : tused_unit;
  1817. hp1 : tmodule;
  1818. begin
  1819. { Reset all numbers to -1 }
  1820. hp1:=tmodule(loaded_units.first);
  1821. while assigned(hp1) do
  1822. begin
  1823. if assigned(hp1.globalsymtable) then
  1824. psymtable(hp1.globalsymtable)^.unitid:=$ffff;
  1825. hp1:=tmodule(hp1.next);
  1826. end;
  1827. { Our own symtable gets unitid 0, for a program there is
  1828. no globalsymtable }
  1829. if assigned(current_module.globalsymtable) then
  1830. psymtable(current_module.globalsymtable)^.unitid:=0;
  1831. { number units }
  1832. counter:=1;
  1833. hp:=tused_unit(current_module.used_units.first);
  1834. while assigned(hp) do
  1835. begin
  1836. psymtable(hp.u.globalsymtable)^.unitid:=counter;
  1837. inc(counter);
  1838. hp:=tused_unit(hp.next);
  1839. end;
  1840. end;
  1841. function findunitsymtable(st:psymtable):psymtable;
  1842. begin
  1843. findunitsymtable:=nil;
  1844. repeat
  1845. if not assigned(st) then
  1846. internalerror(5566561);
  1847. case st^.symtabletype of
  1848. localsymtable,
  1849. parasymtable,
  1850. staticsymtable :
  1851. break;
  1852. globalsymtable,
  1853. unitsymtable :
  1854. begin
  1855. findunitsymtable:=st;
  1856. break;
  1857. end;
  1858. objectsymtable,
  1859. recordsymtable :
  1860. st:=st^.defowner^.owner;
  1861. else
  1862. internalerror(5566562);
  1863. end;
  1864. until false;
  1865. end;
  1866. procedure duplicatesym(sym:psym);
  1867. var
  1868. st : psymtable;
  1869. begin
  1870. Message1(sym_e_duplicate_id,sym^.realname);
  1871. st:=findunitsymtable(sym^.owner);
  1872. with sym^.fileinfo do
  1873. begin
  1874. if assigned(st) and (st^.unitid<>0) then
  1875. Message2(sym_h_duplicate_id_where,'unit '+st^.name^,tostr(line))
  1876. else
  1877. Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line));
  1878. end;
  1879. end;
  1880. procedure identifier_not_found(const s:string);
  1881. begin
  1882. Message1(sym_e_id_not_found,s);
  1883. { show a fatal that you need -S2 or -Sd, but only
  1884. if we just parsed the a token that has m_class }
  1885. if not(m_class in aktmodeswitches) and
  1886. (Upper(s)=pattern) and
  1887. (tokeninfo^[idtoken].keyword=m_class) then
  1888. Message(parser_f_need_objfpc_or_delphi_mode);
  1889. end;
  1890. {*****************************************************************************
  1891. Search
  1892. *****************************************************************************}
  1893. function searchsym(const s : stringid;var srsym:psym;var srsymtable:psymtable):boolean;
  1894. var
  1895. speedvalue : longint;
  1896. begin
  1897. speedvalue:=getspeedvalue(s);
  1898. srsymtable:=symtablestack;
  1899. while assigned(srsymtable) do
  1900. begin
  1901. srsym:=psym(srsymtable^.speedsearch(s,speedvalue));
  1902. if assigned(srsym) then
  1903. begin
  1904. searchsym:=true;
  1905. exit;
  1906. end
  1907. else
  1908. srsymtable:=srsymtable^.next;
  1909. end;
  1910. searchsym:=false;
  1911. end;
  1912. function searchsymonlyin(p : psymtable;const s : stringid):psym;
  1913. var
  1914. srsym : psym;
  1915. begin
  1916. { the caller have to take care if srsym=nil }
  1917. if assigned(p) then
  1918. begin
  1919. srsym:=psym(p^.search(s));
  1920. if assigned(srsym) then
  1921. begin
  1922. searchsymonlyin:=srsym;
  1923. exit;
  1924. end;
  1925. { also check in the local symtbale if it exists }
  1926. if (punitsymtable(p)=punitsymtable(current_module.globalsymtable)) then
  1927. begin
  1928. srsym:=psym(psymtable(current_module.localsymtable)^.search(s));
  1929. if assigned(srsym) then
  1930. begin
  1931. searchsymonlyin:=srsym;
  1932. exit;
  1933. end;
  1934. end
  1935. end;
  1936. searchsymonlyin:=nil;
  1937. end;
  1938. function search_class_member(pd : pobjectdef;const s : string):psym;
  1939. { searches n in symtable of pd and all anchestors }
  1940. var
  1941. speedvalue : longint;
  1942. srsym : psym;
  1943. begin
  1944. speedvalue:=getspeedvalue(s);
  1945. while assigned(pd) do
  1946. begin
  1947. srsym:=psym(pd^.symtable^.speedsearch(s,speedvalue));
  1948. if assigned(srsym) then
  1949. begin
  1950. search_class_member:=srsym;
  1951. exit;
  1952. end;
  1953. pd:=pd^.childof;
  1954. end;
  1955. search_class_member:=nil;
  1956. end;
  1957. function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym;
  1958. {Search for a symbol in a specified symbol table. Returns nil if
  1959. the symtable is not found, and also if the symbol cannot be found
  1960. in the desired symtable }
  1961. var hsymtab:Psymtable;
  1962. res:Psym;
  1963. begin
  1964. res:=nil;
  1965. hsymtab:=symtablestack;
  1966. while (hsymtab<>nil) and (hsymtab^.symtabletype<>symtabletype) do
  1967. hsymtab:=hsymtab^.next;
  1968. if hsymtab<>nil then
  1969. {We found the desired symtable. Now check if the symbol we
  1970. search for is defined in it }
  1971. res:=psym(hsymtab^.search(symbol));
  1972. search_a_symtable:=res;
  1973. end;
  1974. {*****************************************************************************
  1975. Definition Helpers
  1976. *****************************************************************************}
  1977. function globaldef(const s : string) : pdef;
  1978. var st : string;
  1979. symt : psymtable;
  1980. srsym : psym;
  1981. srsymtable : psymtable;
  1982. begin
  1983. srsym := nil;
  1984. if pos('.',s) > 0 then
  1985. begin
  1986. st := copy(s,1,pos('.',s)-1);
  1987. searchsym(st,srsym,srsymtable);
  1988. st := copy(s,pos('.',s)+1,255);
  1989. if assigned(srsym) then
  1990. begin
  1991. if srsym^.typ = unitsym then
  1992. begin
  1993. symt := punitsym(srsym)^.unitsymtable;
  1994. srsym := psym(symt^.search(st));
  1995. end else srsym := nil;
  1996. end;
  1997. end else st := s;
  1998. if srsym = nil then
  1999. searchsym(st,srsym,srsymtable);
  2000. if srsym = nil then
  2001. srsym:=searchsymonlyin(systemunit,st);
  2002. if (not assigned(srsym)) or
  2003. (srsym^.typ<>typesym) then
  2004. begin
  2005. Message(type_e_type_id_expected);
  2006. exit;
  2007. end;
  2008. globaldef := pdef(ptypesym(srsym)^.restype.def);
  2009. end;
  2010. {****************************************************************************
  2011. Object Helpers
  2012. ****************************************************************************}
  2013. var
  2014. _defaultprop : ppropertysym;
  2015. procedure testfordefaultproperty(p : pnamedindexobject);
  2016. begin
  2017. if (psym(p)^.typ=propertysym) and
  2018. (ppo_defaultproperty in ppropertysym(p)^.propoptions) then
  2019. _defaultprop:=ppropertysym(p);
  2020. end;
  2021. function search_default_property(pd : pobjectdef) : ppropertysym;
  2022. { returns the default property of a class, searches also anchestors }
  2023. begin
  2024. _defaultprop:=nil;
  2025. while assigned(pd) do
  2026. begin
  2027. pd^.symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}testfordefaultproperty);
  2028. if assigned(_defaultprop) then
  2029. break;
  2030. pd:=pd^.childof;
  2031. end;
  2032. search_default_property:=_defaultprop;
  2033. end;
  2034. {$ifdef UNITALIASES}
  2035. {****************************************************************************
  2036. TUNIT_ALIAS
  2037. ****************************************************************************}
  2038. constructor tunit_alias.init(const n:string);
  2039. var
  2040. i : longint;
  2041. begin
  2042. i:=pos('=',n);
  2043. if i=0 then
  2044. fail;
  2045. inherited initname(Copy(n,1,i-1));
  2046. newname:=stringdup(Copy(n,i+1,255));
  2047. end;
  2048. destructor tunit_alias.done;
  2049. begin
  2050. stringdispose(newname);
  2051. inherited done;
  2052. end;
  2053. procedure addunitalias(const n:string);
  2054. begin
  2055. unitaliases^.insert(new(punit_alias,init(Upper(n))));
  2056. end;
  2057. function getunitalias(const n:string):string;
  2058. var
  2059. p : punit_alias;
  2060. begin
  2061. p:=punit_alias(unitaliases^.search(Upper(n)));
  2062. if assigned(p) then
  2063. getunitalias:=punit_alias(p)^.newname^
  2064. else
  2065. getunitalias:=n;
  2066. end;
  2067. {$endif UNITALIASES}
  2068. {****************************************************************************
  2069. Symtable Stack
  2070. ****************************************************************************}
  2071. procedure dellexlevel;
  2072. var
  2073. p : psymtable;
  2074. begin
  2075. p:=symtablestack;
  2076. symtablestack:=p^.next;
  2077. { symbol tables of unit interfaces are never disposed }
  2078. { this is handle by the unit unitm }
  2079. if not(p^.symtabletype in [unitsymtable,globalsymtable,stt_exceptsymtable]) then
  2080. dispose(p,done);
  2081. end;
  2082. procedure RestoreUnitSyms;
  2083. var
  2084. p : psymtable;
  2085. begin
  2086. p:=symtablestack;
  2087. while assigned(p) do
  2088. begin
  2089. if (p^.symtabletype=unitsymtable) and
  2090. assigned(punitsymtable(p)^.unitsym) and
  2091. ((punitsymtable(p)^.unitsym^.owner=psymtable(current_module.globalsymtable)) or
  2092. (punitsymtable(p)^.unitsym^.owner=psymtable(current_module.localsymtable))) then
  2093. punitsymtable(p)^.unitsym^.restoreunitsym;
  2094. p:=p^.next;
  2095. end;
  2096. end;
  2097. {$ifdef DEBUG}
  2098. procedure test_symtablestack;
  2099. var
  2100. p : psymtable;
  2101. i : longint;
  2102. begin
  2103. p:=symtablestack;
  2104. i:=0;
  2105. while assigned(p) do
  2106. begin
  2107. inc(i);
  2108. p:=p^.next;
  2109. if i>500 then
  2110. Message(sym_f_internal_error_in_symtablestack);
  2111. end;
  2112. end;
  2113. procedure list_symtablestack;
  2114. var
  2115. p : psymtable;
  2116. i : longint;
  2117. begin
  2118. p:=symtablestack;
  2119. i:=0;
  2120. while assigned(p) do
  2121. begin
  2122. inc(i);
  2123. writeln(i,' ',p^.name^);
  2124. p:=p^.next;
  2125. if i>500 then
  2126. Message(sym_f_internal_error_in_symtablestack);
  2127. end;
  2128. end;
  2129. {$endif DEBUG}
  2130. {****************************************************************************
  2131. Init/Done Symtable
  2132. ****************************************************************************}
  2133. procedure InitSymtable;
  2134. var
  2135. token : ttoken;
  2136. begin
  2137. { Reset symbolstack }
  2138. registerdef:=false;
  2139. read_member:=false;
  2140. symtablestack:=nil;
  2141. systemunit:=nil;
  2142. {$ifdef GDB}
  2143. firstglobaldef:=nil;
  2144. lastglobaldef:=nil;
  2145. globaltypecount:=1;
  2146. pglobaltypecount:=@globaltypecount;
  2147. {$endif GDB}
  2148. { create error syms and def }
  2149. generrorsym:=new(perrorsym,init);
  2150. generrordef:=new(perrordef,init);
  2151. {$ifdef UNITALIASES}
  2152. { unit aliases }
  2153. unitaliases:=new(pdictionary,init);
  2154. {$endif}
  2155. for token:=first_overloaded to last_overloaded do
  2156. overloaded_operators[token]:=nil;
  2157. end;
  2158. procedure DoneSymtable;
  2159. begin
  2160. dispose(generrorsym,done);
  2161. dispose(generrordef,done);
  2162. {$ifdef UNITALIASES}
  2163. dispose(unitaliases,done);
  2164. {$endif}
  2165. end;
  2166. end.
  2167. {
  2168. $Log$
  2169. Revision 1.28 2001-03-13 18:45:07 peter
  2170. * fixed some memory leaks
  2171. Revision 1.27 2001/03/11 22:58:51 peter
  2172. * getsym redesign, removed the globals srsym,srsymtable
  2173. Revision 1.26 2001/02/21 19:37:19 peter
  2174. * moved deref to be done after loading of implementation units. prederef
  2175. is still done directly after loading of symbols and definitions.
  2176. Revision 1.25 2001/02/20 21:41:16 peter
  2177. * new fixfilename, findfile for unix. Look first for lowercase, then
  2178. NormalCase and last for UPPERCASE names.
  2179. Revision 1.24 2001/01/08 21:40:27 peter
  2180. * fixed crash with unsupported token overloading
  2181. Revision 1.23 2000/12/25 00:07:30 peter
  2182. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  2183. tlinkedlist objects)
  2184. Revision 1.22 2000/12/23 19:50:09 peter
  2185. * fixed mem leak with withsymtable
  2186. Revision 1.21 2000/12/10 20:25:32 peter
  2187. * fixed missing typecast
  2188. Revision 1.20 2000/12/10 14:14:51 florian
  2189. * fixed web bug 1203: class fields can be now redefined
  2190. in Delphi mode though I don't like this :/
  2191. Revision 1.19 2000/11/30 22:16:49 florian
  2192. * moved to i386
  2193. Revision 1.18 2000/11/29 00:30:42 florian
  2194. * unused units removed from uses clause
  2195. * some changes for widestrings
  2196. Revision 1.17 2000/11/28 00:28:07 pierre
  2197. * stabs fixing
  2198. Revision 1.1.2.8 2000/11/17 11:14:37 pierre
  2199. * one more class stabs fix
  2200. Revision 1.16 2000/11/12 22:17:47 peter
  2201. * some realname updates for messages
  2202. Revision 1.15 2000/11/06 15:54:15 florian
  2203. * fixed two bugs to get make cycle work, but it's not enough
  2204. Revision 1.14 2000/11/04 14:25:22 florian
  2205. + merged Attila's changes for interfaces, not tested yet
  2206. Revision 1.13 2000/11/01 23:04:38 peter
  2207. * tprocdef.fullprocname added for better casesensitve writing of
  2208. procedures
  2209. Revision 1.12 2000/10/31 22:02:52 peter
  2210. * symtable splitted, no real code changes
  2211. Revision 1.1.2.7 2000/10/16 19:43:04 pierre
  2212. * trying to correct class stabss once more
  2213. Revision 1.11 2000/10/15 07:47:53 peter
  2214. * unit names and procedure names are stored mixed case
  2215. Revision 1.10 2000/10/14 10:14:53 peter
  2216. * moehrendorf oct 2000 rewrite
  2217. Revision 1.9 2000/10/01 19:48:25 peter
  2218. * lot of compile updates for cg11
  2219. Revision 1.8 2000/09/24 15:06:29 peter
  2220. * use defines.inc
  2221. Revision 1.7 2000/08/27 16:11:54 peter
  2222. * moved some util functions from globals,cobjects to cutils
  2223. * splitted files into finput,fmodule
  2224. Revision 1.6 2000/08/21 11:27:45 pierre
  2225. * fix the stabs problems
  2226. Revision 1.5 2000/08/20 14:58:41 peter
  2227. * give fatal if objfpc/delphi mode things are found (merged)
  2228. Revision 1.1.2.6 2000/08/20 14:56:46 peter
  2229. * give fatal if objfpc/delphi mode things are found
  2230. Revision 1.4 2000/08/16 18:33:54 peter
  2231. * splitted namedobjectitem.next into indexnext and listnext so it
  2232. can be used in both lists
  2233. * don't allow "word = word" type definitions (merged)
  2234. Revision 1.3 2000/08/08 19:28:57 peter
  2235. * memdebug/memory patches (merged)
  2236. * only once illegal directive (merged)
  2237. }