symtable.pas 121 KB

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