symsym.pas 103 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  3. Implementation for the symbols types of the symtable
  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 symsym;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cutils,compinnr,
  23. { target }
  24. globtype,globals,widestr,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,symdef,defcmp,
  27. cclasses,
  28. { aasm }
  29. aasmbase,
  30. cpuinfo,cgbase,cgutils,parabase
  31. ;
  32. type
  33. { this class is the base for all symbol objects }
  34. tstoredsym = class(tsym)
  35. private
  36. procedure writeentry(ppufile: tcompilerppufile; ibnr: byte);
  37. protected
  38. procedure ppuwrite_platform(ppufile: tcompilerppufile);virtual;
  39. procedure ppuload_platform(ppufile: tcompilerppufile);virtual;
  40. public
  41. { this is Nil if the symbol has no RTTI attributes }
  42. rtti_attribute_list : trtti_attribute_list;
  43. constructor create(st:tsymtyp;const n : TSymStr);
  44. constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  45. destructor destroy;override;
  46. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  47. { this is called directly after ppuload }
  48. procedure ppuload_subentries(ppufile:tcompilerppufile);virtual;
  49. { this is called directly after ppuwrite }
  50. procedure ppuwrite_subentries(ppufile:tcompilerppufile);virtual;
  51. procedure deref; override;
  52. procedure buildderef; override;
  53. procedure register_sym; override;
  54. end;
  55. tlabelsym = class(tstoredsym)
  56. used,
  57. defined,
  58. nonlocal : boolean;
  59. { points to the matching node, only valid resultdef pass is run and
  60. the goto<->label relation in the node tree is created, should
  61. be a tnode }
  62. code : pointer;
  63. { points to the jump buffer }
  64. jumpbuf : tstoredsym;
  65. { when the label is defined in an asm block, this points to the
  66. generated asmlabel }
  67. asmblocklabel : tasmlabel;
  68. constructor create(const n : TSymStr);virtual;
  69. constructor ppuload(ppufile:tcompilerppufile);
  70. { do not override this routine in platform-specific subclasses,
  71. override ppuwrite_platform instead }
  72. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  73. function mangledname:TSymStr;override;
  74. end;
  75. tlabelsymclass = class of tlabelsym;
  76. tunitsym = class(Tstoredsym)
  77. module : tobject; { tmodule }
  78. constructor create(const n : TSymStr;amodule : tobject);virtual;
  79. constructor ppuload(ppufile:tcompilerppufile);
  80. destructor destroy;override;
  81. { do not override this routine in platform-specific subclasses,
  82. override ppuwrite_platform instead }
  83. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  84. end;
  85. tunitsymclass = class of tunitsym;
  86. tprogramparasym = class(Tstoredsym)
  87. isoindex : dword;
  88. constructor create(const n : TSymStr;i : dword);virtual;
  89. constructor ppuload(ppufile:tcompilerppufile);
  90. destructor destroy;override;
  91. { do not override this routine in platform-specific subclasses,
  92. override ppuwrite_platform instead }
  93. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  94. end;
  95. tprogramparasymclass = class of tprogramparasym;
  96. tnamespacesym = class(Tstoredsym)
  97. unitsym:tsym;
  98. unitsymderef:tderef;
  99. constructor create(const n : TSymStr);virtual;
  100. constructor ppuload(ppufile:tcompilerppufile);
  101. { do not override this routine in platform-specific subclasses,
  102. override ppuwrite_platform instead }
  103. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  104. procedure buildderef;override;
  105. procedure deref;override;
  106. end;
  107. tnamespacesymclass = class of tnamespacesym;
  108. terrorsym = class(Tsym)
  109. constructor create;
  110. procedure register_sym; override;
  111. end;
  112. { tprocsym }
  113. tprocsym = class(tstoredsym)
  114. protected
  115. FProcdefList : TFPObjectList;
  116. FProcdefDerefList : TFPList;
  117. fgenprocsymovlds : tfpobjectlist;
  118. fgenprocsymovldsderefs : tfplist;
  119. public
  120. constructor create(const n : TSymStr);virtual;
  121. constructor ppuload(ppufile:tcompilerppufile);
  122. destructor destroy;override;
  123. { writes all declarations except the specified one }
  124. procedure write_parameter_lists(skipdef:tprocdef);
  125. { tests, if all procedures definitions are defined and not }
  126. { only forward }
  127. procedure check_forward; virtual;
  128. { do not override this routine in platform-specific subclasses,
  129. override ppuwrite_platform instead }
  130. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  131. procedure buildderef;override;
  132. procedure deref;override;
  133. function find_procdef_bytype(pt:Tproctypeoption):Tprocdef;
  134. function find_bytype_parameterless(pt:Tproctypeoption):Tprocdef;
  135. function find_procdef_bypara(para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
  136. function find_procdef_bytype_and_para(pt:Tproctypeoption;para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
  137. function find_procdef_byoptions(ops:tprocoptions): Tprocdef;
  138. function find_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
  139. function find_procdef_assignment_operator(fromdef,todef:tdef;var besteq:tequaltype;isexplicit:boolean):Tprocdef;
  140. function find_procdef_enumerator_operator(fromdef,todef:tdef;var besteq:tequaltype):Tprocdef;
  141. procedure add_generic_overload(sym:tprocsym);
  142. function could_be_implicitly_specialized:boolean;inline;
  143. property ProcdefList:TFPObjectList read FProcdefList;
  144. { only valid if sp_generic_dummy is set and either an overload was
  145. added using add_generic_overload or this was loaded from a ppu }
  146. property genprocsymovlds:tfpobjectlist read fgenprocsymovlds;
  147. end;
  148. tprocsymclass = class of tprocsym;
  149. ttypesym = class(Tstoredsym)
  150. public
  151. typedef : tdef;
  152. typedefderef : tderef;
  153. fprettyname : ansistring;
  154. constructor create(const n : TSymStr;def:tdef);virtual;
  155. destructor destroy;override;
  156. constructor ppuload(ppufile:tcompilerppufile);
  157. { do not override this routine in platform-specific subclasses,
  158. override ppuwrite_platform instead }
  159. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  160. procedure buildderef;override;
  161. procedure deref;override;
  162. function prettyname : string;override;
  163. end;
  164. ttypesymclass = class of ttypesym;
  165. tabstractvarsym = class(tstoredsym)
  166. varoptions : tvaroptions;
  167. varspez : tvarspez; { sets the type of access }
  168. varregable : tvarregable;
  169. varstate : tvarstate;
  170. {could also be part of tabstractnormalvarsym, but there's
  171. one byte left here till the next 4 byte alignment }
  172. varsymaccess : tvarsymaccessflags;
  173. constructor create(st:tsymtyp;const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  174. constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  175. procedure ppuwrite(ppufile:tcompilerppufile);override;
  176. procedure buildderef;override;
  177. procedure deref;override;
  178. function getsize : asizeint;
  179. function getpackedbitsize : longint;
  180. function is_regvar(refpara: boolean):boolean;
  181. private
  182. _vardef : tdef;
  183. vardefderef : tderef;
  184. function get_addr_taken: boolean;
  185. function get_different_scope: boolean;
  186. procedure setregable;
  187. procedure setvardef(const def: tdef);
  188. procedure setvardef_and_regable(def:tdef);
  189. procedure set_addr_taken(AValue: boolean);
  190. procedure set_different_scope(AValue: boolean);
  191. public
  192. property vardef: tdef read _vardef write setvardef_and_regable;
  193. property addr_taken: boolean read get_addr_taken write set_addr_taken;
  194. property different_scope: boolean read get_different_scope write set_different_scope;
  195. end;
  196. tfieldvarsym = class(tabstractvarsym)
  197. { offset in record/object, for bitpacked fields the offset is
  198. given in bit, else in bytes }
  199. fieldoffset : asizeint;
  200. {$ifdef llvm}
  201. { the llvm version of the record does not support variants, }
  202. { so the llvm equivalent field may not be at the exact same }
  203. { offset -> store the difference (bits for bitpacked records, }
  204. { bytes otherwise) }
  205. offsetfromllvmfield : aint;
  206. { number of the closest field in the llvm definition }
  207. llvmfieldnr : longint;
  208. {$endif llvm}
  209. externalname : pshortstring;
  210. {$ifdef symansistr}
  211. cachedmangledname: TSymStr; { mangled name for ObjC or Java }
  212. {$else symansistr}
  213. cachedmangledname: pshortstring; { mangled name for ObjC or Java }
  214. {$endif symansistr}
  215. constructor create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);virtual;
  216. constructor ppuload(ppufile:tcompilerppufile);
  217. { do not override this routine in platform-specific subclasses,
  218. override ppuwrite_platform instead }
  219. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  220. procedure set_externalname(const s:string);virtual;
  221. function mangledname:TSymStr;override;
  222. destructor destroy;override;
  223. {$ifdef DEBUG_NODE_XML}
  224. public
  225. procedure XMLPrintFieldData(var T: Text);
  226. {$endif DEBUG_NODE_XML}
  227. end;
  228. tfieldvarsymclass = class of tfieldvarsym;
  229. tabstractnormalvarsym = class(tabstractvarsym)
  230. defaultconstsym : tsym;
  231. defaultconstsymderef : tderef;
  232. { register/reference for local var }
  233. localloc : TLocation;
  234. { initial location so it can still be initialized later after the location was changed by SSA }
  235. initialloc : TLocation;
  236. { migrated to a parentfpstruct because of nested access (not written to ppu, because not important and would change interface crc) }
  237. inparentfpstruct : boolean;
  238. { the variable is not living at entry of the scope, so it does not need to be initialized if it is a reg. var
  239. (not written to ppu, because not important and would change interface crc) }
  240. noregvarinitneeded : boolean;
  241. constructor create(st:tsymtyp;const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  242. constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  243. function globalasmsym: boolean;
  244. procedure ppuwrite(ppufile:tcompilerppufile);override;
  245. procedure buildderef;override;
  246. procedure deref;override;
  247. end;
  248. tlocalvarsym = class(tabstractnormalvarsym)
  249. constructor create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);virtual;
  250. constructor ppuload(ppufile:tcompilerppufile);
  251. { do not override this routine in platform-specific subclasses,
  252. override ppuwrite_platform instead }
  253. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  254. end;
  255. tlocalvarsymclass = class of tlocalvarsym;
  256. tparavarsym = class(tabstractnormalvarsym)
  257. paraloc : array[callerside..calleeside] of TCGPara;
  258. paranr : word; { position of this parameter }
  259. { in MacPas mode, "univ" parameters mean that type checking should
  260. be disabled, except that the size of the passed parameter must
  261. match the size of the formal parameter }
  262. univpara : boolean;
  263. {$ifdef EXTDEBUG}
  264. eqval : tequaltype;
  265. {$endif EXTDEBUG}
  266. constructor create(const n : TSymStr;nr:word;vsp:tvarspez;def:tdef;vopts:tvaroptions);virtual;
  267. constructor ppuload(ppufile:tcompilerppufile);
  268. destructor destroy;override;
  269. { do not override this routine in platform-specific subclasses,
  270. override ppuwrite_platform instead }
  271. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  272. function needs_finalization: boolean;
  273. function is_used: boolean;
  274. end;
  275. tparavarsymclass = class of tparavarsym;
  276. tstaticvarsym = class(tabstractnormalvarsym)
  277. protected
  278. {$ifdef symansistr}
  279. _mangledbasename,
  280. _mangledname : TSymStr;
  281. {$else symansistr}
  282. _mangledbasename,
  283. _mangledname : pshortstring;
  284. {$endif symansistr}
  285. public
  286. section : ansistring;
  287. { if a text buffer has been defined as being initialized from command line
  288. parameters as it is done by iso pascal with the program symbols,
  289. isoindex contains the parameter number }
  290. isoindex : dword;
  291. { if this static variable was created based on a class field variable then this is set
  292. to the symbol of the corresponding class field }
  293. fieldvarsym : tfieldvarsym;
  294. fieldvarsymderef : tderef;
  295. constructor create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);virtual;
  296. constructor create_dll(const n : TSymStr;vsp:tvarspez;def:tdef);virtual;
  297. constructor create_C(const n: TSymStr; const mangled : TSymStr;vsp:tvarspez;def:tdef);virtual;
  298. constructor create_from_fieldvar(const n: TSymStr;fieldvar:tfieldvarsym);virtual;
  299. constructor ppuload(ppufile:tcompilerppufile);
  300. destructor destroy;override;
  301. { do not override this routine in platform-specific subclasses,
  302. override ppuwrite_platform instead }
  303. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  304. procedure buildderef;override;
  305. procedure deref;override;
  306. function mangledname:TSymStr;override;
  307. procedure set_mangledbasename(const s: TSymStr);
  308. function mangledbasename: TSymStr;
  309. procedure set_mangledname(const s:TSymStr);virtual;
  310. procedure set_raw_mangledname(const s:TSymStr);
  311. end;
  312. tstaticvarsymclass = class of tstaticvarsym;
  313. tabsolutevarsym = class(tabstractvarsym)
  314. public
  315. abstyp : absolutetyp;
  316. asmname : pshortstring;
  317. addroffset : PUint;
  318. ref : tpropaccesslist;
  319. constructor create(const n : TSymStr;def:tdef);virtual;
  320. constructor create_ref(const n : TSymStr;def:tdef;_ref:tpropaccesslist);virtual;
  321. destructor destroy;override;
  322. constructor ppuload(ppufile:tcompilerppufile);
  323. procedure buildderef;override;
  324. procedure deref;override;
  325. function mangledname : TSymStr;override;
  326. { do not override this routine in platform-specific subclasses,
  327. override ppuwrite_platform instead }
  328. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  329. end;
  330. tabsolutevarsymclass = class of tabsolutevarsym;
  331. tpropaccesslisttypes=(palt_none,palt_read,palt_write,palt_stored);
  332. tpropertysym = class(Tstoredsym)
  333. protected
  334. procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); virtual;
  335. public
  336. propoptions : tpropertyoptions;
  337. overriddenpropsym : tpropertysym;
  338. overriddenpropsymderef : tderef;
  339. propdef : tdef;
  340. propdefderef : tderef;
  341. indexdef : tdef;
  342. indexdefderef : tderef;
  343. index,
  344. default : longint;
  345. dispid : longint;
  346. propaccesslist: array[tpropaccesslisttypes] of tpropaccesslist;
  347. parast : tsymtable;
  348. constructor create(const n : TSymStr);virtual;
  349. destructor destroy;override;
  350. constructor ppuload(ppufile:tcompilerppufile);
  351. function getsize : asizeint;
  352. { do not override this routine in platform-specific subclasses,
  353. override ppuwrite_platform instead }
  354. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  355. procedure buildderef;override;
  356. procedure deref;override;
  357. function getpropaccesslist(pap:tpropaccesslisttypes;out plist:tpropaccesslist):boolean;
  358. { copies the settings of the current propertysym to p; a bit like
  359. a form of getcopy, but without the name }
  360. procedure makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
  361. procedure add_accessor_parameters(readprocdef, writeprocdef: tprocdef);
  362. procedure add_index_parameter(var paranr: word; readprocdef, writeprocdef: tprocdef);
  363. { set up the accessors for this property }
  364. procedure add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
  365. procedure register_override(overriddenprop: tpropertysym);
  366. { inherit the read/write property }
  367. procedure inherit_accessor(getset: tpropaccesslisttypes); virtual;
  368. end;
  369. tpropertysymclass = class of tpropertysym;
  370. tconstvalue = record
  371. case integer of
  372. 0: (valueord : tconstexprint);
  373. 1: (valueordptr : tconstptruint);
  374. 2: (valueptr : pointer; len : longint);
  375. end;
  376. tconstsym = class(tstoredsym)
  377. constdef : tdef;
  378. constdefderef : tderef;
  379. consttyp : tconsttyp;
  380. value : tconstvalue;
  381. constructor create_ord(const n : TSymStr;t : tconsttyp;v : tconstexprint;def:tdef);virtual;
  382. constructor create_ordptr(const n : TSymStr;t : tconsttyp;v : tconstptruint;def:tdef);virtual;
  383. constructor create_ptr(const n : TSymStr;t : tconsttyp;v : pointer;def:tdef);virtual;
  384. constructor create_string(const n : TSymStr;t : tconsttyp;str:pchar;l:longint;def:tdef);virtual;
  385. constructor create_wstring(const n : TSymStr;t : tconsttyp;pw:pcompilerwidestring);virtual;
  386. constructor create_undefined(const n : TSymStr;def:tdef);virtual;
  387. constructor ppuload(ppufile:tcompilerppufile);
  388. destructor destroy;override;
  389. procedure buildderef;override;
  390. procedure deref;override;
  391. { do not override this routine in platform-specific subclasses,
  392. override ppuwrite_platform instead }
  393. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  394. {$ifdef DEBUG_NODE_XML}
  395. public
  396. procedure XMLPrintConstData(var T: Text);
  397. {$endif DEBUG_NODE_XML}
  398. end;
  399. tconstsymclass = class of tconstsym;
  400. tenumsym = class(Tstoredsym)
  401. value : longint;
  402. definition : tenumdef;
  403. definitionderef : tderef;
  404. constructor create(const n : TSymStr;def : tenumdef;v : longint);virtual;
  405. constructor ppuload(ppufile:tcompilerppufile);
  406. { do not override this routine in platform-specific subclasses,
  407. override ppuwrite_platform instead }
  408. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  409. procedure buildderef;override;
  410. procedure deref;override;
  411. end;
  412. tenumsymclass = class of tenumsym;
  413. tsyssym = class(Tstoredsym)
  414. number : tinlinenumber;
  415. constructor create(const n : TSymStr;l : tinlinenumber);virtual;
  416. constructor ppuload(ppufile:tcompilerppufile);
  417. destructor destroy;override;
  418. { do not override this routine in platform-specific subclasses,
  419. override ppuwrite_platform instead }
  420. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  421. class function find_by_number(l:longint):tsyssym;
  422. end;
  423. tsyssymclass = class of tsyssym;
  424. const
  425. maxmacrolen=16*1024;
  426. type
  427. pmacrobuffer = ^tmacrobuffer;
  428. tmacrobuffer = array[0..maxmacrolen-1] of char;
  429. tmacro = class(tstoredsym)
  430. {Normally true, but false when a previously defined macro is undef-ed}
  431. defined : boolean;
  432. {True if this is a mac style compiler variable, in which case no macro
  433. substitutions shall be done.}
  434. is_compiler_var : boolean;
  435. {Whether the macro was used. NOTE: A use of a macro which was never defined}
  436. {e. g. an IFDEF which returns false, will not be registered as used,}
  437. {since there is no place to register its use. }
  438. is_used : boolean;
  439. buftext : pchar;
  440. buflen : longint;
  441. constructor create(const n : TSymStr);
  442. constructor ppuload(ppufile:tcompilerppufile);
  443. { do not override this routine in platform-specific subclasses,
  444. override ppuwrite_platform instead }
  445. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  446. destructor destroy;override;
  447. function GetCopy:tmacro;
  448. end;
  449. var
  450. generrorsym : tsym;
  451. clabelsym: tlabelsymclass;
  452. cunitsym: tunitsymclass;
  453. cprogramparasym: tprogramparasymclass;
  454. cnamespacesym: tnamespacesymclass;
  455. cprocsym: tprocsymclass;
  456. ctypesym: ttypesymclass;
  457. cfieldvarsym: tfieldvarsymclass;
  458. clocalvarsym: tlocalvarsymclass;
  459. cparavarsym: tparavarsymclass;
  460. cstaticvarsym: tstaticvarsymclass;
  461. cabsolutevarsym: tabsolutevarsymclass;
  462. cpropertysym: tpropertysymclass;
  463. cconstsym: tconstsymclass;
  464. cenumsym: tenumsymclass;
  465. csyssym: tsyssymclass;
  466. { generate internal static field name based on regular field name }
  467. function internal_static_field_name(const fieldname: TSymStr): TSymStr;
  468. function get_high_value_sym(vs: tparavarsym):tabstractvarsym; { marking it as inline causes IE 200311075 during loading from ppu file }
  469. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);inline;
  470. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring;filepos:tfileposinfo);
  471. function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean;
  472. implementation
  473. uses
  474. { global }
  475. verbose,
  476. { target }
  477. systems,
  478. { symtable }
  479. defutil,symtable,
  480. fmodule,
  481. { tree }
  482. node,
  483. { aasm }
  484. aasmdata,
  485. { codegen }
  486. paramgr,
  487. procinfo,
  488. { ppu }
  489. entfile,ppu
  490. ;
  491. {****************************************************************************
  492. Helpers
  493. ****************************************************************************}
  494. function internal_static_field_name(const fieldname: TSymStr): TSymStr;
  495. begin
  496. result:='$_static_'+fieldname;
  497. end;
  498. function get_high_value_sym(vs: tparavarsym):tabstractvarsym;
  499. begin
  500. result := tabstractvarsym(vs.owner.Find('high'+vs.name));
  501. end;
  502. function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean;
  503. begin
  504. result:=false;
  505. case consttyp of
  506. constnone,
  507. constnil:
  508. result:=true;
  509. constord:
  510. result:=value1.valueord=value2.valueord;
  511. constpointer:
  512. result:=value1.valueordptr=value2.valueordptr;
  513. conststring,
  514. constreal,
  515. constset,
  516. constresourcestring,
  517. constwstring,
  518. constguid: begin
  519. if value1.len<>value2.len then
  520. exit(false);
  521. result:=CompareByte(value1.valueptr^,value2.valueptr^,value1.len)=0;
  522. end;
  523. end;
  524. end;
  525. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
  526. begin
  527. check_hints(srsym,symoptions,deprecatedmsg,current_filepos);
  528. end;
  529. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring;filepos:tfileposinfo);
  530. begin
  531. if not assigned(srsym) then
  532. internalerror(200602051);
  533. if sp_hint_deprecated in symoptions then
  534. if (sp_has_deprecated_msg in symoptions) and (deprecatedmsg <> nil) then
  535. MessagePos2(filepos,sym_w_deprecated_symbol_with_msg,srsym.realname,deprecatedmsg^)
  536. else
  537. MessagePos1(filepos,sym_w_deprecated_symbol,srsym.realname);
  538. if sp_hint_experimental in symoptions then
  539. MessagePos1(filepos,sym_w_experimental_symbol,srsym.realname);
  540. if sp_hint_platform in symoptions then
  541. MessagePos1(filepos,sym_w_non_portable_symbol,srsym.realname);
  542. if sp_hint_library in symoptions then
  543. MessagePos1(filepos,sym_w_library_symbol,srsym.realname);
  544. if sp_hint_unimplemented in symoptions then
  545. MessagePos1(filepos,sym_w_non_implemented_symbol,srsym.realname);
  546. end;
  547. {****************************************************************************
  548. TSYM (base for all symtypes)
  549. ****************************************************************************}
  550. constructor tstoredsym.create(st:tsymtyp;const n : TSymStr);
  551. begin
  552. inherited create(st,n);
  553. end;
  554. constructor tstoredsym.ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  555. begin
  556. {$ifdef symansistr}
  557. inherited Create(st,ppufile.getansistring);
  558. {$else symansistr}
  559. inherited Create(st,ppufile.getstring);
  560. {$endif symansistr}
  561. SymId:=ppufile.getlongint;
  562. current_module.symlist[SymId]:=self;
  563. ppufile.getposinfo(fileinfo);
  564. visibility:=tvisibility(ppufile.getbyte);
  565. ppufile.getset(tppuset2(symoptions));
  566. if sp_has_deprecated_msg in symoptions then
  567. deprecatedmsg:=ppufile.getpshortstring
  568. else
  569. deprecatedmsg:=nil;
  570. rtti_attribute_list:=trtti_attribute_list.ppuload(ppufile);
  571. end;
  572. procedure tstoredsym.ppuwrite(ppufile:tcompilerppufile);
  573. var
  574. oldintfcrc : boolean;
  575. begin
  576. {$ifdef symansistr}
  577. ppufile.putansistring(realname);
  578. {$else}
  579. ppufile.putstring(realname);
  580. {$endif}
  581. ppufile.putlongint(SymId);
  582. ppufile.putposinfo(fileinfo);
  583. ppufile.putbyte(byte(visibility));
  584. { symoptions can differ between interface and implementation, except
  585. for overload (this is checked in pdecsub.proc_add_definition() )
  586. These differences can lead to compiler crashes, so ignore them.
  587. This does mean that changing e.g. the "deprecated" state of a symbol
  588. by itself will not trigger a recompilation of dependent units.
  589. }
  590. oldintfcrc:=ppufile.do_interface_crc;
  591. ppufile.do_interface_crc:=false;
  592. ppufile.putset(tppuset2(symoptions));
  593. if sp_has_deprecated_msg in symoptions then
  594. ppufile.putstring(deprecatedmsg^);
  595. ppufile.do_interface_crc:=oldintfcrc;
  596. trtti_attribute_list.ppuwrite(rtti_attribute_list,ppufile);
  597. end;
  598. procedure tstoredsym.ppuload_subentries(ppufile: tcompilerppufile);
  599. begin
  600. trtti_attribute_list.ppuload_subentries(rtti_attribute_list,ppufile);
  601. end;
  602. procedure tstoredsym.ppuwrite_subentries(ppufile: tcompilerppufile);
  603. begin
  604. trtti_attribute_list.ppuwrite_subentries(rtti_attribute_list,ppufile);
  605. end;
  606. procedure tstoredsym.deref;
  607. begin
  608. inherited;
  609. if assigned(rtti_attribute_list) then
  610. rtti_attribute_list.deref;
  611. end;
  612. procedure tstoredsym.buildderef;
  613. begin
  614. inherited;
  615. if not registered then
  616. register_sym;
  617. if assigned(rtti_attribute_list) then
  618. rtti_attribute_list.buildderef;
  619. end;
  620. procedure tstoredsym.writeentry(ppufile: tcompilerppufile; ibnr: byte);
  621. begin
  622. ppuwrite_platform(ppufile);
  623. ppufile.writeentry(ibnr);
  624. end;
  625. procedure tstoredsym.ppuwrite_platform(ppufile: tcompilerppufile);
  626. begin
  627. { by default: do nothing }
  628. end;
  629. procedure tstoredsym.ppuload_platform(ppufile: tcompilerppufile);
  630. begin
  631. { by default: do nothing }
  632. end;
  633. destructor tstoredsym.destroy;
  634. begin
  635. rtti_attribute_list.free;
  636. inherited destroy;
  637. end;
  638. procedure tstoredsym.register_sym;
  639. begin
  640. if registered then
  641. exit;
  642. { Register in current_module }
  643. if assigned(current_module) then
  644. begin
  645. current_module.symlist.Add(self);
  646. SymId:=current_module.symlist.Count-1;
  647. end
  648. else
  649. SymId:=symid_registered_nost;
  650. end;
  651. {****************************************************************************
  652. TLABELSYM
  653. ****************************************************************************}
  654. constructor tlabelsym.create(const n : TSymStr);
  655. begin
  656. inherited create(labelsym,n);
  657. used:=false;
  658. defined:=false;
  659. nonlocal:=false;
  660. code:=nil;
  661. end;
  662. constructor tlabelsym.ppuload(ppufile:tcompilerppufile);
  663. begin
  664. inherited ppuload(labelsym,ppufile);
  665. code:=nil;
  666. used:=false;
  667. nonlocal:=false;
  668. defined:=true;
  669. ppuload_platform(ppufile);
  670. end;
  671. procedure tlabelsym.ppuwrite(ppufile:tcompilerppufile);
  672. begin
  673. if owner.symtabletype=globalsymtable then
  674. Message(sym_e_ill_label_decl)
  675. else
  676. begin
  677. inherited ppuwrite(ppufile);
  678. writeentry(ppufile,iblabelsym);
  679. end;
  680. end;
  681. function tlabelsym.mangledname:TSymStr;
  682. begin
  683. if (asmblocklabel=nil) then
  684. begin
  685. if nonlocal then
  686. current_asmdata.getglobaljumplabel(asmblocklabel)
  687. else
  688. current_asmdata.getjumplabel(asmblocklabel);
  689. end;
  690. result:=asmblocklabel.name;
  691. end;
  692. {****************************************************************************
  693. TUNITSYM
  694. ****************************************************************************}
  695. constructor tunitsym.create(const n : TSymStr;amodule : tobject);
  696. begin
  697. inherited create(unitsym,n);
  698. module:=amodule;
  699. end;
  700. constructor tunitsym.ppuload(ppufile:tcompilerppufile);
  701. begin
  702. inherited ppuload(unitsym,ppufile);
  703. module:=nil;
  704. ppuload_platform(ppufile);
  705. end;
  706. destructor tunitsym.destroy;
  707. begin
  708. inherited destroy;
  709. end;
  710. procedure tunitsym.ppuwrite(ppufile:tcompilerppufile);
  711. begin
  712. inherited ppuwrite(ppufile);
  713. writeentry(ppufile,ibunitsym);
  714. end;
  715. {****************************************************************************
  716. TPROGRAMPARASYM
  717. ****************************************************************************}
  718. constructor tprogramparasym.create(const n : TSymStr; i : dword);
  719. begin
  720. inherited create(programparasym,n);
  721. isoindex:=i;
  722. end;
  723. constructor tprogramparasym.ppuload(ppufile : tcompilerppufile);
  724. begin
  725. { program parameter syms (iso pascal style) might be never written to a ppu }
  726. internalerror(2015050102);
  727. end;
  728. destructor tprogramparasym.destroy;
  729. begin
  730. inherited destroy;
  731. end;
  732. procedure tprogramparasym.ppuwrite(ppufile : tcompilerppufile);
  733. begin
  734. { program parameter syms (iso pascal style) might be never written to a ppu }
  735. internalerror(2015050101);
  736. end;
  737. {****************************************************************************
  738. TNAMESPACESYM
  739. ****************************************************************************}
  740. constructor tnamespacesym.create(const n : TSymStr);
  741. begin
  742. inherited create(namespacesym,n);
  743. unitsym:=nil;
  744. unitsymderef.reset;
  745. end;
  746. constructor tnamespacesym.ppuload(ppufile:tcompilerppufile);
  747. begin
  748. inherited ppuload(namespacesym,ppufile);
  749. ppufile.getderef(unitsymderef);
  750. ppuload_platform(ppufile);
  751. end;
  752. procedure tnamespacesym.ppuwrite(ppufile:tcompilerppufile);
  753. begin
  754. inherited ppuwrite(ppufile);
  755. ppufile.putderef(unitsymderef);
  756. writeentry(ppufile,ibnamespacesym);
  757. end;
  758. procedure tnamespacesym.buildderef;
  759. begin
  760. inherited buildderef;
  761. unitsymderef.build(unitsym);
  762. end;
  763. procedure tnamespacesym.deref;
  764. begin
  765. inherited deref;
  766. unitsym:=tsym(unitsymderef.resolve);
  767. end;
  768. {****************************************************************************
  769. TPROCSYM
  770. ****************************************************************************}
  771. constructor tprocsym.create(const n : TSymStr);
  772. var
  773. i: longint;
  774. begin
  775. if not(ts_lowercase_proc_start in current_settings.targetswitches) or
  776. (n='') then
  777. inherited create(procsym,n)
  778. else
  779. begin
  780. { YToX -> yToX
  781. RC64Encode -> rc64Encode
  782. Test -> test
  783. }
  784. i:=2;
  785. while i<=length(n) do
  786. begin
  787. if not(n[i] in ['A'..'Z']) then
  788. begin
  789. if (i>2) and
  790. (n[i] in ['a'..'z']) then
  791. dec(i);
  792. break;
  793. end;
  794. inc(i);
  795. end;
  796. inherited create(procsym,lower(copy(n,1,i-1))+copy(n,i,length(n)));
  797. end;
  798. FProcdefList:=TFPObjectList.Create(false);
  799. FProcdefderefList:=nil;
  800. { the tprocdef have their own symoptions, make the procsym
  801. always visible }
  802. visibility:=vis_public;
  803. end;
  804. constructor tprocsym.ppuload(ppufile:tcompilerppufile);
  805. var
  806. symderef,
  807. pdderef : tderef;
  808. i,
  809. symcnt,
  810. pdcnt : longint;
  811. begin
  812. inherited ppuload(procsym,ppufile);
  813. FProcdefList:=TFPObjectList.Create(false);
  814. FProcdefDerefList:=TFPList.Create;
  815. pdcnt:=ppufile.getword;
  816. for i:=1 to pdcnt do
  817. begin
  818. ppufile.getderef(pdderef);
  819. FProcdefDerefList.Add(Pointer(PtrInt(pdderef.dataidx)));
  820. end;
  821. if sp_generic_dummy in symoptions then
  822. begin
  823. fgenprocsymovlds:=tfpobjectlist.create(false);
  824. fgenprocsymovldsderefs:=tfplist.create;
  825. symcnt:=ppufile.getword;
  826. for i:=1 to symcnt do
  827. begin
  828. ppufile.getderef(symderef);
  829. fgenprocsymovldsderefs.add(pointer(ptrint(symderef.dataidx)));
  830. end;
  831. end;
  832. ppuload_platform(ppufile);
  833. end;
  834. destructor tprocsym.destroy;
  835. begin
  836. FProcdefList.Free;
  837. if assigned(FProcdefDerefList) then
  838. FProcdefDerefList.Free;
  839. fgenprocsymovlds.free;
  840. fgenprocsymovldsderefs.free;
  841. inherited destroy;
  842. end;
  843. procedure tprocsym.ppuwrite(ppufile:tcompilerppufile);
  844. var
  845. i : longint;
  846. d : tderef;
  847. begin
  848. inherited ppuwrite(ppufile);
  849. if fprocdefdereflist=nil then
  850. internalerror(2013121801);
  851. ppufile.putword(FProcdefDerefList.Count);
  852. for i:=0 to FProcdefDerefList.Count-1 do
  853. begin
  854. d.dataidx:=PtrInt(FProcdefDerefList[i]);
  855. ppufile.putderef(d);
  856. end;
  857. if sp_generic_dummy in symoptions then
  858. begin
  859. if not assigned(fgenprocsymovldsderefs) then
  860. internalerror(2021010301);
  861. ppufile.putword(fgenprocsymovldsderefs.count);
  862. for i:=0 to fgenprocsymovldsderefs.count-1 do
  863. begin
  864. d.dataidx:=ptrint(fgenprocsymovldsderefs[i]);
  865. ppufile.putderef(d);
  866. end;
  867. end;
  868. writeentry(ppufile,ibprocsym);
  869. end;
  870. procedure tprocsym.write_parameter_lists(skipdef:tprocdef);
  871. var
  872. i : longint;
  873. pd : tprocdef;
  874. begin
  875. for i:=0 to ProcdefList.Count-1 do
  876. begin
  877. pd:=tprocdef(ProcdefList[i]);
  878. if pd<>skipdef then
  879. MessagePos1(pd.fileinfo,sym_e_param_list,pd.fullprocname(false));
  880. end;
  881. end;
  882. procedure tprocsym.check_forward;
  883. var
  884. i : longint;
  885. pd : tprocdef;
  886. begin
  887. for i:=0 to ProcdefList.Count-1 do
  888. begin
  889. pd:=tprocdef(ProcdefList[i]);
  890. if (pd.owner=owner) and (pd.forwarddef) then
  891. begin
  892. { For mode macpas. Make implicit externals (procedures declared in the interface
  893. section which do not have a counterpart in the implementation)
  894. to be an imported procedure }
  895. if (m_mac in current_settings.modeswitches) and
  896. (pd.interfacedef) then
  897. begin
  898. pd.setmangledname(target_info.CPrefix+tprocdef(pd).procsym.realname);
  899. if (not current_module.interface_only) then
  900. MessagePos1(pd.fileinfo,sym_w_forward_not_resolved,pd.fullprocname(false));
  901. end
  902. else
  903. begin
  904. MessagePos1(pd.fileinfo,sym_e_forward_not_resolved,pd.fullprocname(false));
  905. end;
  906. { Turn further error messages off }
  907. pd.forwarddef:=false;
  908. end;
  909. end;
  910. end;
  911. procedure tprocsym.buildderef;
  912. var
  913. i : longint;
  914. pd : tprocdef;
  915. d : tderef;
  916. sym : tprocsym;
  917. begin
  918. inherited;
  919. if not assigned(FProcdefDerefList) then
  920. FProcdefDerefList:=TFPList.Create
  921. else
  922. FProcdefDerefList.Clear;
  923. for i:=0 to ProcdefList.Count-1 do
  924. begin
  925. pd:=tprocdef(ProcdefList[i]);
  926. { only write the proc definitions that belong
  927. to this procsym and are in the global symtable }
  928. if pd.owner=owner then
  929. begin
  930. d.build(pd);
  931. FProcdefDerefList.Add(Pointer(PtrInt(d.dataidx)));
  932. end;
  933. end;
  934. if sp_generic_dummy in symoptions then
  935. begin
  936. if not assigned(fgenprocsymovlds) then
  937. internalerror(2021010602);
  938. if not assigned(fgenprocsymovldsderefs) then
  939. fgenprocsymovldsderefs:=tfplist.create
  940. else
  941. fgenprocsymovldsderefs.clear;
  942. for i:=0 to fgenprocsymovlds.count-1 do
  943. begin
  944. sym:=tprocsym(fgenprocsymovlds[i]);
  945. d.build(sym);
  946. fgenprocsymovldsderefs.add(pointer(ptrint(d.dataidx)));
  947. end;
  948. end;
  949. end;
  950. procedure tprocsym.deref;
  951. var
  952. i : longint;
  953. pd : tprocdef;
  954. d : tderef;
  955. sym : tsym;
  956. begin
  957. { Clear all procdefs }
  958. ProcdefList.Clear;
  959. if not assigned(FProcdefDerefList) then
  960. internalerror(200611031);
  961. for i:=0 to FProcdefDerefList.Count-1 do
  962. begin
  963. d.dataidx:=PtrInt(FProcdefDerefList[i]);
  964. pd:=tprocdef(d.resolve);
  965. ProcdefList.Add(pd);
  966. end;
  967. if sp_generic_dummy in symoptions then
  968. begin
  969. if not assigned(fgenprocsymovlds) then
  970. internalerror(2021010603);
  971. if not assigned(fgenprocsymovldsderefs) then
  972. internalerror(2021010302);
  973. fgenprocsymovlds.clear;
  974. for i:= 0 to fgenprocsymovldsderefs.count-1 do
  975. begin
  976. d.dataidx:=ptrint(fgenprocsymovldsderefs[i]);
  977. sym:=tprocsym(d.resolve);
  978. fgenprocsymovlds.add(sym);
  979. end;
  980. end;
  981. end;
  982. function Tprocsym.Find_procdef_bytype(pt:Tproctypeoption):Tprocdef;
  983. var
  984. i : longint;
  985. pd : tprocdef;
  986. begin
  987. result:=nil;
  988. for i:=0 to ProcdefList.Count-1 do
  989. begin
  990. pd:=tprocdef(ProcdefList[i]);
  991. if pd.proctypeoption=pt then
  992. begin
  993. result:=pd;
  994. exit;
  995. end;
  996. end;
  997. end;
  998. function tprocsym.find_bytype_parameterless(pt: Tproctypeoption): Tprocdef;
  999. var
  1000. i,j : longint;
  1001. pd : tprocdef;
  1002. found : boolean;
  1003. begin
  1004. result:=nil;
  1005. for i:=0 to ProcdefList.Count-1 do
  1006. begin
  1007. pd:=tprocdef(ProcdefList[i]);
  1008. if (pd.proctypeoption=pt) then
  1009. begin
  1010. found:=true;
  1011. for j:=0 to pd.paras.count-1 do
  1012. begin
  1013. if not(vo_is_hidden_para in tparavarsym(pd.paras[j]).varoptions) then
  1014. begin
  1015. found:=false;
  1016. break;
  1017. end;
  1018. end;
  1019. if found then
  1020. begin
  1021. result:=pd;
  1022. exit;
  1023. end;
  1024. end;
  1025. end;
  1026. end;
  1027. function check_procdef_paras(pd:tprocdef;para:TFPObjectList;retdef:tdef;
  1028. cpoptions:tcompare_paras_options): tprocdef;
  1029. var
  1030. eq: tequaltype;
  1031. begin
  1032. result:=nil;
  1033. if assigned(retdef) then
  1034. eq:=compare_defs(retdef,pd.returndef,nothingn)
  1035. else
  1036. eq:=te_equal;
  1037. if (eq>=te_equal) or
  1038. ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
  1039. begin
  1040. eq:=compare_paras(para,pd.paras,cp_value_equal_const,cpoptions);
  1041. if (eq>=te_equal) or
  1042. ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
  1043. begin
  1044. result:=pd;
  1045. exit;
  1046. end;
  1047. end;
  1048. end;
  1049. function Tprocsym.Find_procdef_bypara(para:TFPObjectList;retdef:tdef;
  1050. cpoptions:tcompare_paras_options):Tprocdef;
  1051. var
  1052. i : longint;
  1053. pd : tprocdef;
  1054. begin
  1055. result:=nil;
  1056. for i:=0 to ProcdefList.Count-1 do
  1057. begin
  1058. pd:=tprocdef(ProcdefList[i]);
  1059. result:=check_procdef_paras(pd,para,retdef,cpoptions);
  1060. if assigned(result) then
  1061. exit;
  1062. end;
  1063. end;
  1064. function Tprocsym.find_procdef_bytype_and_para(pt:Tproctypeoption;
  1065. para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
  1066. var
  1067. i : longint;
  1068. pd : tprocdef;
  1069. begin
  1070. result:=nil;
  1071. for i:=0 to ProcdefList.Count-1 do
  1072. begin
  1073. pd:=tprocdef(ProcdefList[i]);
  1074. if pd.proctypeoption=pt then
  1075. begin
  1076. result:=check_procdef_paras(pd,para,retdef,cpoptions);
  1077. if assigned(result) then
  1078. exit;
  1079. end;
  1080. end;
  1081. end;
  1082. function tprocsym.find_procdef_byoptions(ops: tprocoptions): Tprocdef;
  1083. var
  1084. i : longint;
  1085. pd : tprocdef;
  1086. begin
  1087. result:=nil;
  1088. for i:=0 to ProcdefList.Count-1 do
  1089. begin
  1090. pd:=tprocdef(ProcdefList[i]);
  1091. if ops * pd.procoptions = ops then
  1092. begin
  1093. result:=pd;
  1094. exit;
  1095. end;
  1096. end;
  1097. end;
  1098. function Tprocsym.Find_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
  1099. var
  1100. i : longint;
  1101. bestpd,
  1102. pd : tprocdef;
  1103. eq,besteq : tequaltype;
  1104. sym: tsym;
  1105. ps: tprocsym;
  1106. begin
  1107. { This function will return the pprocdef of pprocsym that
  1108. is the best match for procvardef. When there are multiple
  1109. matches it returns nil.}
  1110. result:=nil;
  1111. bestpd:=nil;
  1112. besteq:=te_incompatible;
  1113. ps:=self;
  1114. repeat
  1115. for i:=0 to ps.ProcdefList.Count-1 do
  1116. begin
  1117. pd:=tprocdef(ps.ProcdefList[i]);
  1118. eq:=proc_to_procvar_equal(pd,d,false);
  1119. if eq>=te_convert_l1 then
  1120. begin
  1121. { multiple procvars with the same equal level }
  1122. if assigned(bestpd) and
  1123. (besteq=eq) then
  1124. exit;
  1125. if eq>besteq then
  1126. begin
  1127. besteq:=eq;
  1128. bestpd:=pd;
  1129. end;
  1130. end;
  1131. end;
  1132. { maybe TODO: also search class helpers? -- this code is similar to
  1133. what happens in htypechk in
  1134. tcallcandidates.collect_overloads_in_struct: keep searching in
  1135. parent types in case the currently found procdef is marked as
  1136. "overload" and we haven't found a proper match yet }
  1137. if assigned(ps.owner.defowner) and
  1138. (ps.owner.defowner.typ=objectdef) and
  1139. assigned(tobjectdef(ps.owner.defowner).childof) and
  1140. (not assigned(bestpd) or
  1141. (po_overload in bestpd.procoptions)) then
  1142. begin
  1143. sym:=tsym(tobjectdef(ps.owner.defowner).childof.symtable.find(ps.name));
  1144. if assigned(sym) and
  1145. (sym.typ=procsym) then
  1146. ps:=tprocsym(sym)
  1147. else
  1148. ps:=nil;
  1149. end
  1150. else
  1151. ps:=nil;
  1152. until (besteq>=te_equal) or
  1153. not assigned(ps);
  1154. result:=bestpd;
  1155. end;
  1156. function Tprocsym.Find_procdef_assignment_operator(fromdef,todef:tdef;var besteq:tequaltype;isexplicit:boolean):Tprocdef;
  1157. var
  1158. paraidx, realparamcount,
  1159. i, j : longint;
  1160. bestpd,
  1161. hpd,
  1162. pd : tprocdef;
  1163. convtyp : tconverttype;
  1164. eq : tequaltype;
  1165. shortstringcount : longint;
  1166. checkshortstring,
  1167. isgenshortstring : boolean;
  1168. begin
  1169. { This function will return the pprocdef of pprocsym that
  1170. is the best match for fromdef and todef. }
  1171. result:=nil;
  1172. bestpd:=nil;
  1173. besteq:=te_incompatible;
  1174. { special handling for assignment operators overloads to shortstring:
  1175. for implicit assignment we pick the ShortString one if available and
  1176. only pick one with specific length if it is the *only* one }
  1177. shortstringcount:=0;
  1178. checkshortstring:=not isexplicit and
  1179. is_shortstring(todef) and
  1180. (tstringdef(todef).len<>255);
  1181. for i:=0 to ProcdefList.Count-1 do
  1182. begin
  1183. pd:=tprocdef(ProcdefList[i]);
  1184. if (pd.owner.symtabletype=staticsymtable) and not pd.owner.iscurrentunit then
  1185. continue;
  1186. if (equal_defs(todef,pd.returndef) or
  1187. { shortstrings of different lengths are ok as result }
  1188. (not isexplicit and is_shortstring(todef) and is_shortstring(pd.returndef))) and
  1189. { the result type must be always really equal and not an alias,
  1190. if you mess with this code, check tw4093 }
  1191. ((todef=pd.returndef) or
  1192. (
  1193. not(df_unique in todef.defoptions) and
  1194. not(df_unique in pd.returndef.defoptions)
  1195. )
  1196. ) then
  1197. begin
  1198. paraidx:=0;
  1199. { ignore vs_hidden parameters }
  1200. while (paraidx<pd.paras.count) and
  1201. assigned(pd.paras[paraidx]) and
  1202. (vo_is_hidden_para in tparavarsym(pd.paras[paraidx]).varoptions) do
  1203. inc(paraidx);
  1204. realparamcount:=0;
  1205. for j := 0 to pd.paras.Count-1 do
  1206. if assigned(pd.paras[j]) and not (vo_is_hidden_para in tparavarsym(pd.paras[j]).varoptions) then
  1207. inc(realparamcount);
  1208. if (paraidx<pd.paras.count) and
  1209. assigned(pd.paras[paraidx]) and
  1210. (realparamcount = 1) then
  1211. begin
  1212. eq:=compare_defs_ext(fromdef,tparavarsym(pd.paras[paraidx]).vardef,nothingn,convtyp,hpd,[]);
  1213. { alias? if yes, only l1 choice,
  1214. if you mess with this code, check tw4093 }
  1215. if (eq=te_exact) and
  1216. (fromdef<>tparavarsym(pd.paras[paraidx]).vardef) and
  1217. ((df_unique in fromdef.defoptions) or
  1218. (df_unique in tparavarsym(pd.paras[paraidx]).vardef.defoptions)) then
  1219. eq:=te_convert_l1;
  1220. isgenshortstring:=false;
  1221. if checkshortstring and is_shortstring(pd.returndef) then
  1222. if tstringdef(pd.returndef).len<>255 then
  1223. inc(shortstringcount)
  1224. else
  1225. isgenshortstring:=true;
  1226. if (eq=te_exact) and (not checkshortstring or isgenshortstring) then
  1227. begin
  1228. besteq:=eq;
  1229. result:=pd;
  1230. exit;
  1231. end;
  1232. if eq>besteq then
  1233. begin
  1234. bestpd:=pd;
  1235. besteq:=eq;
  1236. end;
  1237. end;
  1238. end;
  1239. end;
  1240. if checkshortstring and (shortstringcount>1) then
  1241. begin
  1242. besteq:=te_incompatible;
  1243. bestpd:=nil;
  1244. end;
  1245. result:=bestpd;
  1246. end;
  1247. function Tprocsym.find_procdef_enumerator_operator(fromdef,todef:tdef;var besteq:tequaltype):Tprocdef;
  1248. var
  1249. paraidx, realparamcount,
  1250. i, j : longint;
  1251. bestpd,
  1252. hpd,
  1253. pd : tprocdef;
  1254. current : tpropertysym;
  1255. convtyp : tconverttype;
  1256. eq : tequaltype;
  1257. begin
  1258. { This function will return the pprocdef of pprocsym that
  1259. is the best match for fromdef and todef. }
  1260. result:=nil;
  1261. bestpd:=nil;
  1262. besteq:=te_incompatible;
  1263. for i:=0 to ProcdefList.Count-1 do
  1264. begin
  1265. pd:=tprocdef(ProcdefList[i]);
  1266. if (pd.owner.symtabletype=staticsymtable) and not pd.owner.iscurrentunit then
  1267. continue;
  1268. if not (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) then
  1269. continue;
  1270. current := tpropertysym(tabstractrecorddef(pd.returndef).search_enumerator_current);
  1271. if (current = nil) then
  1272. continue;
  1273. // compare current result def with the todef
  1274. if (equal_defs(todef, current.propdef) or
  1275. { shortstrings of different lengths are ok as result }
  1276. (is_shortstring(todef) and is_shortstring(current.propdef))) and
  1277. { the result type must be always really equal and not an alias,
  1278. if you mess with this code, check tw4093 }
  1279. ((todef=current.propdef) or
  1280. (
  1281. not(df_unique in todef.defoptions) and
  1282. not(df_unique in current.propdef.defoptions)
  1283. )
  1284. ) then
  1285. begin
  1286. paraidx:=0;
  1287. { ignore vs_hidden parameters }
  1288. while (paraidx<pd.paras.count) and
  1289. assigned(pd.paras[paraidx]) and
  1290. (vo_is_hidden_para in tparavarsym(pd.paras[paraidx]).varoptions) do
  1291. inc(paraidx);
  1292. realparamcount:=0;
  1293. for j := 0 to pd.paras.Count-1 do
  1294. if assigned(pd.paras[j]) and not (vo_is_hidden_para in tparavarsym(pd.paras[j]).varoptions) then
  1295. inc(realparamcount);
  1296. if (paraidx<pd.paras.count) and
  1297. assigned(pd.paras[paraidx]) and
  1298. (realparamcount = 1) then
  1299. begin
  1300. eq:=compare_defs_ext(fromdef,tparavarsym(pd.paras[paraidx]).vardef,nothingn,convtyp,hpd,[]);
  1301. { alias? if yes, only l1 choice,
  1302. if you mess with this code, check tw4093 }
  1303. if (eq=te_exact) and
  1304. (fromdef<>tparavarsym(pd.paras[paraidx]).vardef) and
  1305. ((df_unique in fromdef.defoptions) or
  1306. (df_unique in tparavarsym(pd.paras[paraidx]).vardef.defoptions)) then
  1307. eq:=te_convert_l1;
  1308. if eq=te_exact then
  1309. begin
  1310. besteq:=eq;
  1311. result:=pd;
  1312. exit;
  1313. end;
  1314. if eq>besteq then
  1315. begin
  1316. bestpd:=pd;
  1317. besteq:=eq;
  1318. end;
  1319. end;
  1320. end;
  1321. end;
  1322. result:=bestpd;
  1323. end;
  1324. procedure tprocsym.add_generic_overload(sym:tprocsym);
  1325. var
  1326. i : longint;
  1327. begin
  1328. if not (sp_generic_dummy in symoptions) then
  1329. internalerror(2021010601);
  1330. if not assigned(fgenprocsymovlds) then
  1331. fgenprocsymovlds:=tfpobjectlist.create(false);
  1332. for i:=0 to genprocsymovlds.count-1 do
  1333. if tprocsym(genprocsymovlds[i])=sym then
  1334. exit;
  1335. genprocsymovlds.add(sym);
  1336. end;
  1337. function tprocsym.could_be_implicitly_specialized:boolean;
  1338. begin
  1339. result:=(m_implicit_function_specialization in current_settings.modeswitches) and
  1340. (sp_generic_dummy in symoptions) and
  1341. assigned(genprocsymovlds);
  1342. end;
  1343. {****************************************************************************
  1344. TERRORSYM
  1345. ****************************************************************************}
  1346. constructor terrorsym.create;
  1347. begin
  1348. inherited create(errorsym,'');
  1349. end;
  1350. procedure terrorsym.register_sym;
  1351. begin
  1352. { these should never be written to a ppu file, since they don't
  1353. derive from tstoredsym }
  1354. Internalerror(2015101801);
  1355. end;
  1356. {****************************************************************************
  1357. TPROPERTYSYM
  1358. ****************************************************************************}
  1359. procedure tpropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
  1360. begin
  1361. { do nothing by default }
  1362. end;
  1363. constructor tpropertysym.create(const n : TSymStr);
  1364. var
  1365. pap : tpropaccesslisttypes;
  1366. begin
  1367. inherited create(propertysym,n);
  1368. propoptions:=[];
  1369. index:=0;
  1370. default:=0;
  1371. propdef:=nil;
  1372. propdefderef.reset;
  1373. indexdef:=nil;
  1374. indexdefderef.reset;
  1375. parast:=nil;
  1376. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1377. propaccesslist[pap]:=tpropaccesslist.create;
  1378. end;
  1379. constructor tpropertysym.ppuload(ppufile:tcompilerppufile);
  1380. var
  1381. pap : tpropaccesslisttypes;
  1382. begin
  1383. inherited ppuload(propertysym,ppufile);
  1384. ppufile.getset(tppuset2(propoptions));
  1385. if ppo_overrides in propoptions then
  1386. ppufile.getderef(overriddenpropsymderef);
  1387. ppufile.getderef(propdefderef);
  1388. index:=ppufile.getlongint;
  1389. default:=ppufile.getlongint;
  1390. ppufile.getderef(indexdefderef);
  1391. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1392. propaccesslist[pap]:=ppufile.getpropaccesslist;
  1393. ppuload_platform(ppufile);
  1394. if [ppo_hasparameters,ppo_overrides]*propoptions=[ppo_hasparameters] then
  1395. begin
  1396. parast:=tparasymtable.create(nil,0);
  1397. tparasymtable(parast).ppuload(ppufile);
  1398. end
  1399. else
  1400. parast:=nil;
  1401. end;
  1402. destructor tpropertysym.destroy;
  1403. var
  1404. pap : tpropaccesslisttypes;
  1405. begin
  1406. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1407. propaccesslist[pap].free;
  1408. parast.free;
  1409. inherited destroy;
  1410. end;
  1411. procedure tpropertysym.buildderef;
  1412. var
  1413. pap : tpropaccesslisttypes;
  1414. begin
  1415. inherited;
  1416. propdefderef.build(propdef);
  1417. indexdefderef.build(indexdef);
  1418. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1419. propaccesslist[pap].buildderef;
  1420. if ppo_overrides in propoptions then
  1421. overriddenpropsymderef.build(overriddenpropsym)
  1422. else
  1423. if ppo_hasparameters in propoptions then
  1424. tparasymtable(parast).buildderef;
  1425. end;
  1426. procedure tpropertysym.deref;
  1427. var
  1428. pap : tpropaccesslisttypes;
  1429. begin
  1430. indexdef:=tdef(indexdefderef.resolve);
  1431. propdef:=tdef(propdefderef.resolve);
  1432. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1433. propaccesslist[pap].resolve;
  1434. if ppo_overrides in propoptions then
  1435. begin
  1436. overriddenpropsym:=tpropertysym(overriddenpropsymderef.resolve);
  1437. if ppo_hasparameters in propoptions then
  1438. parast:=overriddenpropsym.parast.getcopy;
  1439. end
  1440. else
  1441. if ppo_hasparameters in propoptions then
  1442. tparasymtable(parast).deref(false)
  1443. end;
  1444. function tpropertysym.getpropaccesslist(pap:tpropaccesslisttypes;out plist:tpropaccesslist):boolean;
  1445. var
  1446. hpropsym : tpropertysym;
  1447. begin
  1448. result:=false;
  1449. { find property in the overridden list }
  1450. hpropsym:=self;
  1451. repeat
  1452. plist:=hpropsym.propaccesslist[pap];
  1453. if not plist.empty then
  1454. begin
  1455. result:=true;
  1456. exit;
  1457. end;
  1458. hpropsym:=hpropsym.overriddenpropsym;
  1459. until not assigned(hpropsym);
  1460. end;
  1461. procedure tpropertysym.add_accessor_parameters(readprocdef, writeprocdef: tprocdef);
  1462. var
  1463. i: integer;
  1464. orig, hparavs: tparavarsym;
  1465. begin
  1466. for i := 0 to parast.SymList.Count - 1 do
  1467. begin
  1468. orig:=tparavarsym(parast.SymList[i]);
  1469. if assigned(readprocdef) then
  1470. begin
  1471. hparavs:=cparavarsym.create(orig.RealName,orig.paranr,orig.varspez,orig.vardef,[]);
  1472. readprocdef.parast.insertsym(hparavs);
  1473. end;
  1474. if assigned(writeprocdef) then
  1475. begin
  1476. hparavs:=cparavarsym.create(orig.RealName,orig.paranr,orig.varspez,orig.vardef,[]);
  1477. writeprocdef.parast.insertsym(hparavs);
  1478. end;
  1479. end;
  1480. end;
  1481. procedure tpropertysym.add_index_parameter(var paranr: word; readprocdef, writeprocdef: tprocdef);
  1482. var
  1483. hparavs: tparavarsym;
  1484. begin
  1485. inc(paranr);
  1486. if assigned(readprocdef) then
  1487. begin
  1488. hparavs:=cparavarsym.create('$index',10*paranr,vs_value,indexdef,[]);
  1489. readprocdef.parast.insertsym(hparavs);
  1490. end;
  1491. if assigned(writeprocdef) then
  1492. begin
  1493. hparavs:=cparavarsym.create('$index',10*paranr,vs_value,indexdef,[]);
  1494. writeprocdef.parast.insertsym(hparavs);
  1495. end;
  1496. end;
  1497. procedure tpropertysym.add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
  1498. var
  1499. cpo: tcompare_paras_options;
  1500. begin
  1501. case sym.typ of
  1502. procsym :
  1503. begin
  1504. { search procdefs matching accessordef }
  1505. { we ignore hidden stuff here because the property access symbol might have
  1506. non default calling conventions which might change the hidden stuff;
  1507. see tw3216.pp (FK) }
  1508. cpo:=[cpo_allowdefaults,cpo_ignorehidden];
  1509. { allow var-parameters for setters in case of VARPROPSETTER+ }
  1510. if (getset=palt_write) and
  1511. (cs_varpropsetter in current_settings.localswitches) then
  1512. include(cpo,cpo_ignorevarspez);
  1513. propaccesslist[getset].procdef:=tprocsym(sym).find_procdef_bypara(accessordef.paras,accessordef.returndef,cpo);
  1514. if not assigned(propaccesslist[getset].procdef) or
  1515. { because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
  1516. ((sp_static in symoptions)<>tprocdef(propaccesslist[getset].procdef).no_self_node) then
  1517. Message(parser_e_ill_property_access_sym)
  1518. else
  1519. finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
  1520. end;
  1521. fieldvarsym :
  1522. begin
  1523. if not assigned(fielddef) then
  1524. internalerror(200310071);
  1525. if compare_defs(fielddef,propdef,nothingn)>=te_equal then
  1526. begin
  1527. { property parameters are allowed if this is
  1528. an indexed property, because the index is then
  1529. the parameter.
  1530. Note: In the help of Kylix it is written
  1531. that it isn't allowed, but the compiler accepts it (PFV) }
  1532. if (ppo_hasparameters in propoptions) or
  1533. ((sp_static in symoptions) <> (sp_static in sym.symoptions)) then
  1534. Message(parser_e_ill_property_access_sym)
  1535. else
  1536. finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
  1537. end
  1538. else
  1539. IncompatibleTypes(fielddef,propdef);
  1540. end;
  1541. else
  1542. Message(parser_e_ill_property_access_sym);
  1543. end;
  1544. end;
  1545. procedure tpropertysym.register_override(overriddenprop: tpropertysym);
  1546. begin
  1547. overriddenpropsym:=tpropertysym(overriddenprop);
  1548. include(propoptions,ppo_overrides);
  1549. end;
  1550. procedure tpropertysym.inherit_accessor(getset: tpropaccesslisttypes);
  1551. begin
  1552. { nothing to do by default }
  1553. end;
  1554. procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
  1555. begin
  1556. { inherit all type related entries }
  1557. p.indexdef:=indexdef;
  1558. p.propdef:=propdef;
  1559. p.index:=index;
  1560. p.default:=default;
  1561. p.propoptions:=propoptions;
  1562. paranr:=0;
  1563. if ppo_hasparameters in propoptions then
  1564. begin
  1565. p.parast:=parast.getcopy;
  1566. p.add_accessor_parameters(readprocdef,writeprocdef);
  1567. paranr:=p.parast.SymList.Count;
  1568. end;
  1569. if ppo_indexed in p.propoptions then
  1570. p.add_index_parameter(paranr,readprocdef,writeprocdef);
  1571. end;
  1572. function tpropertysym.getsize : asizeint;
  1573. begin
  1574. getsize:=0;
  1575. end;
  1576. procedure tpropertysym.ppuwrite(ppufile:tcompilerppufile);
  1577. var
  1578. pap : tpropaccesslisttypes;
  1579. begin
  1580. inherited ppuwrite(ppufile);
  1581. ppufile.putset(tppuset2(propoptions));
  1582. if ppo_overrides in propoptions then
  1583. ppufile.putderef(overriddenpropsymderef);
  1584. ppufile.putderef(propdefderef);
  1585. ppufile.putlongint(index);
  1586. ppufile.putlongint(default);
  1587. ppufile.putderef(indexdefderef);
  1588. for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
  1589. ppufile.putpropaccesslist(propaccesslist[pap]);
  1590. writeentry(ppufile,ibpropertysym);
  1591. if [ppo_hasparameters,ppo_overrides]*propoptions=[ppo_hasparameters] then
  1592. tparasymtable(parast).ppuwrite(ppufile);
  1593. end;
  1594. {****************************************************************************
  1595. TABSTRACTVARSYM
  1596. ****************************************************************************}
  1597. constructor tabstractvarsym.create(st:tsymtyp;const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  1598. begin
  1599. inherited create(st,n);
  1600. vardef:=def;
  1601. vardefderef.reset;
  1602. varspez:=vsp;
  1603. varstate:=vs_declared;
  1604. varoptions:=vopts;
  1605. end;
  1606. constructor tabstractvarsym.ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  1607. begin
  1608. inherited ppuload(st,ppufile);
  1609. varstate:=vs_readwritten;
  1610. varspez:=tvarspez(ppufile.getbyte);
  1611. varregable:=tvarregable(ppufile.getbyte);
  1612. ppufile.getset(tppuset1(varsymaccess));
  1613. ppufile.getderef(vardefderef);
  1614. ppufile.getset(tppuset4(varoptions));
  1615. end;
  1616. procedure tabstractvarsym.buildderef;
  1617. begin
  1618. inherited;
  1619. vardefderef.build(vardef);
  1620. end;
  1621. procedure tabstractvarsym.deref;
  1622. begin
  1623. { assigning vardef also updates varregable. We just loaded this }
  1624. { value from a ppu, so it must not be changed (e.g. tw7817a.pp/ }
  1625. { tw7817b.pp: the address is taken of a local variable in an }
  1626. { inlined procedure -> must remain non-regable when inlining) }
  1627. setvardef(tdef(vardefderef.resolve));
  1628. end;
  1629. procedure tabstractvarsym.ppuwrite(ppufile:tcompilerppufile);
  1630. var
  1631. oldintfcrc : boolean;
  1632. begin
  1633. inherited ppuwrite(ppufile);
  1634. ppufile.putbyte(byte(varspez));
  1635. oldintfcrc:=ppufile.do_crc;
  1636. ppufile.do_crc:=false;
  1637. ppufile.putbyte(byte(varregable));
  1638. ppufile.putset(tppuset1(varsymaccess));
  1639. ppufile.do_crc:=oldintfcrc;
  1640. ppufile.putderef(vardefderef);
  1641. ppufile.putset(tppuset4(varoptions));
  1642. end;
  1643. function tabstractvarsym.getsize : asizeint;
  1644. begin
  1645. if assigned(vardef) and
  1646. ((vardef.typ<>arraydef) or
  1647. is_dynamic_array(vardef) or
  1648. (tarraydef(vardef).highrange>=tarraydef(vardef).lowrange)) then
  1649. result:=vardef.size
  1650. else
  1651. result:=0;
  1652. end;
  1653. function tabstractvarsym.getpackedbitsize : longint;
  1654. begin
  1655. { bitpacking is only done for ordinals }
  1656. if not is_ordinal(vardef) then
  1657. internalerror(2006082010);
  1658. result:=vardef.packedbitsize;
  1659. end;
  1660. function tabstractvarsym.is_regvar(refpara: boolean):boolean;
  1661. var
  1662. tempdef : tdef;
  1663. begin
  1664. { Register variables are not allowed in the following cases:
  1665. - regvars are disabled
  1666. - exceptions are used (after an exception is raised the contents of the
  1667. registers is not valid anymore)
  1668. - it has a local copy
  1669. - the value needs to be in memory (i.e. reference counted) }
  1670. result:=(cs_opt_regvar in current_settings.optimizerswitches) and
  1671. not(pi_has_assembler_block in current_procinfo.flags) and
  1672. not(pi_uses_exceptions in current_procinfo.flags) and
  1673. not(pi_has_interproclabel in current_procinfo.flags) and
  1674. ((refpara and
  1675. (varregable <> vr_none)) or
  1676. (not refpara and
  1677. not(varregable in [vr_none,vr_addr])))
  1678. {$if not defined(powerpc) and not defined(powerpc64)}
  1679. and ((vardef.typ <> recorddef) or
  1680. (varregable = vr_addr) or
  1681. tabstractrecordsymtable(tabstractrecorddef(vardef).symtable).has_single_field(tempdef) or
  1682. not(varstate in [vs_written,vs_readwritten]));
  1683. {$endif}
  1684. end;
  1685. procedure tabstractvarsym.setvardef_and_regable(def:tdef);
  1686. begin
  1687. setvardef(def);
  1688. setregable;
  1689. end;
  1690. procedure tabstractvarsym.set_addr_taken(AValue: boolean);
  1691. begin
  1692. if AValue then
  1693. include(varsymaccess, vsa_addr_taken)
  1694. else
  1695. exclude(varsymaccess, vsa_addr_taken);
  1696. end;
  1697. procedure tabstractvarsym.set_different_scope(AValue: boolean);
  1698. begin
  1699. if AValue then
  1700. include(varsymaccess, vsa_different_scope)
  1701. else
  1702. exclude(varsymaccess, vsa_different_scope);
  1703. end;
  1704. procedure tabstractvarsym.setregable;
  1705. begin
  1706. if vo_volatile in varoptions then
  1707. exit;
  1708. { can we load the value into a register ? }
  1709. if not assigned(owner) or
  1710. (owner.symtabletype in [localsymtable, parasymtable]) or
  1711. (
  1712. (owner.symtabletype=staticsymtable) and
  1713. not(cs_create_pic in current_settings.moduleswitches)
  1714. ) then
  1715. begin
  1716. if (tstoreddef(vardef).is_intregable and
  1717. { we could keep all aint*2 records in registers, but this causes
  1718. too much spilling for CPUs with 8-16 registers so keep only
  1719. parameters and function results of this type in register because they are normally
  1720. passed by register anyways
  1721. This can be changed, as soon as we have full ssa (FK) }
  1722. ((typ=paravarsym) or
  1723. (vo_is_funcret in varoptions) or
  1724. (tstoreddef(vardef).typ<>recorddef) or
  1725. (tstoreddef(vardef).size<=sizeof(aint)))) or
  1726. { const parameters can be put into registers if the def fits into a register }
  1727. (tstoreddef(vardef).is_const_intregable and
  1728. (typ=paravarsym) and
  1729. (varspez=vs_const)) then
  1730. varregable:=vr_intreg
  1731. else if tstoreddef(vardef).is_fpuregable then
  1732. begin
  1733. if use_vectorfpu(vardef) then
  1734. varregable:=vr_mmreg
  1735. else
  1736. varregable:=vr_fpureg;
  1737. end
  1738. else if is_vector(vardef) and
  1739. fits_in_mm_register(vardef) then
  1740. begin
  1741. varregable:=vr_mmreg;
  1742. end;
  1743. end;
  1744. end;
  1745. function tabstractvarsym.get_addr_taken: boolean;
  1746. begin
  1747. result:=vsa_addr_taken in varsymaccess;
  1748. end;
  1749. function tabstractvarsym.get_different_scope: boolean;
  1750. begin
  1751. result:=vsa_different_scope in varsymaccess;
  1752. end;
  1753. procedure tabstractvarsym.setvardef(const def: tdef);
  1754. begin
  1755. _vardef := def;
  1756. end;
  1757. {****************************************************************************
  1758. TFIELDVARSYM
  1759. ****************************************************************************}
  1760. constructor tfieldvarsym.create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  1761. begin
  1762. inherited create(fieldvarsym,n,vsp,def,vopts);
  1763. fieldoffset:=-1;
  1764. end;
  1765. constructor tfieldvarsym.ppuload(ppufile:tcompilerppufile);
  1766. begin
  1767. inherited ppuload(fieldvarsym,ppufile);
  1768. fieldoffset:=ppufile.getasizeint;
  1769. if (vo_has_mangledname in varoptions) then
  1770. externalname:=ppufile.getpshortstring
  1771. else
  1772. externalname:=nil;
  1773. ppuload_platform(ppufile);
  1774. end;
  1775. procedure tfieldvarsym.ppuwrite(ppufile:tcompilerppufile);
  1776. begin
  1777. inherited ppuwrite(ppufile);
  1778. ppufile.putasizeint(fieldoffset);
  1779. if (vo_has_mangledname in varoptions) then
  1780. ppufile.putstring(externalname^);
  1781. writeentry(ppufile,ibfieldvarsym);
  1782. end;
  1783. procedure tfieldvarsym.set_externalname(const s: string);
  1784. begin
  1785. internalerror(2014033001);
  1786. end;
  1787. function tfieldvarsym.mangledname:TSymStr;
  1788. var
  1789. srsym : tsym;
  1790. srsymtable : tsymtable;
  1791. begin
  1792. if sp_static in symoptions then
  1793. begin
  1794. if searchsym(lower(owner.name^)+'_'+name,srsym,srsymtable) then
  1795. result:=srsym.mangledname
  1796. { when generating the debug info for the module in which the }
  1797. { symbol is defined, the localsymtable of that module is }
  1798. { already popped from the symtablestack }
  1799. else if searchsym_in_module(current_module,lower(owner.name^)+'_'+name,srsym,srsymtable) then
  1800. result:=srsym.mangledname
  1801. else
  1802. internalerror(2007012501);
  1803. end
  1804. else if is_objcclass(tdef(owner.defowner)) then
  1805. begin
  1806. {$ifdef symansistr}
  1807. if cachedmangledname<>'' then
  1808. result:=cachedmangledname
  1809. {$else symansistr}
  1810. if assigned(cachedmangledname) then
  1811. result:=cachedmangledname^
  1812. {$endif symansistr}
  1813. else
  1814. begin
  1815. result:=target_info.cprefix+'OBJC_IVAR_$_'+tobjectdef(owner.defowner).objextname^+'.'+RealName;
  1816. {$ifdef symansistr}
  1817. cachedmangledname:=result;
  1818. {$else symansistr}
  1819. cachedmangledname:=stringdup(result);
  1820. {$endif symansistr}
  1821. end;
  1822. end
  1823. else
  1824. result:=inherited mangledname;
  1825. end;
  1826. destructor tfieldvarsym.destroy;
  1827. begin
  1828. {$ifndef symansistr}
  1829. stringdispose(cachedmangledname);
  1830. {$endif symansistr}
  1831. stringdispose(externalname);
  1832. inherited destroy;
  1833. end;
  1834. {$ifdef DEBUG_NODE_XML}
  1835. procedure TFieldVarSym.XMLPrintFieldData(var T: Text);
  1836. begin
  1837. WriteLn(T, PrintNodeIndention, '<type>', SanitiseXMLString(vardef.GetTypeName), '</type>');
  1838. WriteLn(T, PrintNodeIndention, '<visibility>', visibility, '</visibility>');
  1839. WriteLn(T, PrintNodeIndention, '<offset>', fieldoffset, '</offset>');
  1840. WriteLn(T, PrintNodeIndention, '<size>', vardef.size, '</size>');
  1841. end;
  1842. {$endif DEBUG_NODE_XML}
  1843. {****************************************************************************
  1844. TABSTRACTNORMALVARSYM
  1845. ****************************************************************************}
  1846. constructor tabstractnormalvarsym.create(st:tsymtyp;const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  1847. begin
  1848. inherited create(st,n,vsp,def,vopts);
  1849. fillchar(localloc,sizeof(localloc),0);
  1850. fillchar(initialloc,sizeof(initialloc),0);
  1851. defaultconstsym:=nil;
  1852. defaultconstsymderef.reset;
  1853. end;
  1854. constructor tabstractnormalvarsym.ppuload(st:tsymtyp;ppufile:tcompilerppufile);
  1855. begin
  1856. inherited ppuload(st,ppufile);
  1857. fillchar(localloc,sizeof(localloc),0);
  1858. fillchar(initialloc,sizeof(initialloc),0);
  1859. ppufile.getderef(defaultconstsymderef);
  1860. end;
  1861. function tabstractnormalvarsym.globalasmsym: boolean;
  1862. begin
  1863. result:=
  1864. (owner.symtabletype=globalsymtable) or
  1865. (create_smartlink and
  1866. not(tf_smartlink_sections in target_info.flags)) or
  1867. current_module.islibrary or
  1868. (assigned(current_procinfo) and
  1869. ((po_inline in current_procinfo.procdef.procoptions) or
  1870. { globalasmsym is called normally before the body of a subroutine is parsed
  1871. so we cannot know if it will be auto inlined, so make all symbols of it
  1872. global if asked }
  1873. (not(po_noinline in current_procinfo.procdef.procoptions) and
  1874. (cs_opt_autoinline in current_settings.optimizerswitches)))
  1875. ) or
  1876. (vo_is_public in varoptions);
  1877. end;
  1878. procedure tabstractnormalvarsym.buildderef;
  1879. begin
  1880. inherited buildderef;
  1881. defaultconstsymderef.build(defaultconstsym);
  1882. end;
  1883. procedure tabstractnormalvarsym.deref;
  1884. begin
  1885. inherited deref;
  1886. defaultconstsym:=tsym(defaultconstsymderef.resolve);
  1887. end;
  1888. procedure tabstractnormalvarsym.ppuwrite(ppufile:tcompilerppufile);
  1889. begin
  1890. inherited ppuwrite(ppufile);
  1891. ppufile.putderef(defaultconstsymderef);
  1892. end;
  1893. {****************************************************************************
  1894. Tstaticvarsym
  1895. ****************************************************************************}
  1896. constructor tstaticvarsym.create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  1897. begin
  1898. inherited create(staticvarsym,n,vsp,def,vopts);
  1899. fieldvarsymderef.reset;
  1900. {$ifdef symansistr}
  1901. _mangledname:='';
  1902. {$else symansistr}
  1903. _mangledname:=nil;
  1904. {$endif symansistr}
  1905. end;
  1906. constructor tstaticvarsym.create_dll(const n : TSymStr;vsp:tvarspez;def:tdef);
  1907. begin
  1908. tstaticvarsym(self).create(n,vsp,def,[vo_is_dll_var]);
  1909. end;
  1910. constructor tstaticvarsym.create_C(const n: TSymStr; const mangled : TSymStr;vsp:tvarspez;def:tdef);
  1911. begin
  1912. tstaticvarsym(self).create(n,vsp,def,[]);
  1913. set_mangledname(mangled);
  1914. end;
  1915. constructor tstaticvarsym.create_from_fieldvar(const n: TSymStr;fieldvar:tfieldvarsym);
  1916. begin
  1917. create(internal_static_field_name(n),fieldvar.varspez,fieldvar.vardef,[]);
  1918. fieldvarsym:=fieldvar;
  1919. end;
  1920. constructor tstaticvarsym.ppuload(ppufile:tcompilerppufile);
  1921. begin
  1922. inherited ppuload(staticvarsym,ppufile);
  1923. {$ifdef symansistr}
  1924. if vo_has_mangledname in varoptions then
  1925. _mangledname:=ppufile.getansistring
  1926. else
  1927. _mangledname:='';
  1928. {$else symansistr}
  1929. if vo_has_mangledname in varoptions then
  1930. _mangledname:=ppufile.getpshortstring
  1931. else
  1932. _mangledname:=nil;
  1933. {$endif symansistr}
  1934. if vo_has_section in varoptions then
  1935. section:=ppufile.getansistring;
  1936. ppufile.getderef(fieldvarsymderef);
  1937. ppuload_platform(ppufile);
  1938. end;
  1939. destructor tstaticvarsym.destroy;
  1940. begin
  1941. {$ifndef symansistr}
  1942. if assigned(_mangledname) then
  1943. begin
  1944. {$ifdef MEMDEBUG}
  1945. memmanglednames.start;
  1946. {$endif MEMDEBUG}
  1947. stringdispose(_mangledname);
  1948. {$ifdef MEMDEBUG}
  1949. memmanglednames.stop;
  1950. {$endif MEMDEBUG}
  1951. end;
  1952. stringdispose(_mangledbasename);
  1953. {$endif}
  1954. inherited destroy;
  1955. end;
  1956. procedure tstaticvarsym.ppuwrite(ppufile:tcompilerppufile);
  1957. begin
  1958. inherited ppuwrite(ppufile);
  1959. { write mangledname rather than _mangledname in case the mangledname
  1960. has not been calculated yet (can happen in case only the
  1961. mangledbasename has been set) }
  1962. if vo_has_mangledname in varoptions then
  1963. {$ifdef symansistr}
  1964. ppufile.putansistring(mangledname);
  1965. {$else symansistr}
  1966. ppufile.putstring(mangledname);
  1967. {$endif symansistr}
  1968. if vo_has_section in varoptions then
  1969. ppufile.putansistring(section);
  1970. ppufile.putderef(fieldvarsymderef);
  1971. writeentry(ppufile,ibstaticvarsym);
  1972. end;
  1973. procedure tstaticvarsym.buildderef;
  1974. begin
  1975. inherited buildderef;
  1976. fieldvarsymderef.build(fieldvarsym);
  1977. end;
  1978. procedure tstaticvarsym.deref;
  1979. begin
  1980. inherited deref;
  1981. fieldvarsym:=tfieldvarsym(fieldvarsymderef.resolve);
  1982. end;
  1983. function tstaticvarsym.mangledname:TSymStr;
  1984. var
  1985. usename,
  1986. prefix : TSymStr;
  1987. begin
  1988. {$ifdef symansistr}
  1989. if _mangledname='' then
  1990. {$else symansistr}
  1991. if not assigned(_mangledname) then
  1992. {$endif symansistr}
  1993. begin
  1994. if (vo_is_typed_const in varoptions) then
  1995. prefix:='TC'
  1996. else
  1997. prefix:='U';
  1998. {$ifdef symansistr}
  1999. if _mangledbasename='' then
  2000. usename:=name
  2001. else
  2002. usename:=_mangledbasename;
  2003. _mangledname:=make_mangledname(prefix,owner,usename);
  2004. {$else symansistr}
  2005. if not assigned(_mangledbasename) then
  2006. usename:=name
  2007. else
  2008. usename:=_mangledbasename^;
  2009. _mangledname:=stringdup(make_mangledname(prefix,owner,usename));
  2010. {$endif symansistr}
  2011. end;
  2012. {$ifdef symansistr}
  2013. result:=_mangledname;
  2014. {$else symansistr}
  2015. result:=_mangledname^;
  2016. {$endif symansistr}
  2017. end;
  2018. procedure tstaticvarsym.set_mangledbasename(const s: TSymStr);
  2019. begin
  2020. {$ifdef symansistr}
  2021. _mangledbasename:=s;
  2022. _mangledname:='';
  2023. {$else symansistr}
  2024. stringdispose(_mangledname);
  2025. stringdispose(_mangledbasename);
  2026. _mangledbasename:=stringdup(s);
  2027. {$endif symansistr}
  2028. include(varoptions,vo_has_mangledname);
  2029. end;
  2030. function tstaticvarsym.mangledbasename: TSymStr;
  2031. begin
  2032. {$ifdef symansistr}
  2033. result:=_mangledbasename;
  2034. {$else symansistr}
  2035. if assigned(_mangledbasename) then
  2036. result:=_mangledbasename^
  2037. else
  2038. result:='';
  2039. {$endif symansistr}
  2040. end;
  2041. procedure tstaticvarsym.set_mangledname(const s:TSymStr);
  2042. begin
  2043. {$ifdef symansistr}
  2044. _mangledname:=s;
  2045. {$else symansistr}
  2046. stringdispose(_mangledname);
  2047. _mangledname:=stringdup(s);
  2048. {$endif symansistr}
  2049. include(varoptions,vo_has_mangledname);
  2050. end;
  2051. procedure tstaticvarsym.set_raw_mangledname(const s: TSymStr);
  2052. begin
  2053. {$ifndef symansistr}
  2054. stringdispose(_mangledname);
  2055. _mangledname:=stringdup(s);
  2056. {$else}
  2057. _mangledname:=s;
  2058. {$endif}
  2059. include(varoptions,vo_has_mangledname);
  2060. end;
  2061. {****************************************************************************
  2062. TLOCALVARSYM
  2063. ****************************************************************************}
  2064. constructor tlocalvarsym.create(const n : TSymStr;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  2065. begin
  2066. inherited create(localvarsym,n,vsp,def,vopts);
  2067. end;
  2068. constructor tlocalvarsym.ppuload(ppufile:tcompilerppufile);
  2069. begin
  2070. inherited ppuload(localvarsym,ppufile);
  2071. ppuload_platform(ppufile);
  2072. end;
  2073. procedure tlocalvarsym.ppuwrite(ppufile:tcompilerppufile);
  2074. begin
  2075. inherited ppuwrite(ppufile);
  2076. writeentry(ppufile,iblocalvarsym);
  2077. end;
  2078. {****************************************************************************
  2079. TPARAVARSYM
  2080. ****************************************************************************}
  2081. constructor tparavarsym.create(const n : TSymStr;nr:word;vsp:tvarspez;def:tdef;vopts:tvaroptions);
  2082. begin
  2083. inherited create(paravarsym,n,vsp,def,vopts);
  2084. if (vsp in [vs_var,vs_value,vs_const,vs_constref]) and
  2085. not(vo_is_funcret in vopts) then
  2086. varstate := vs_initialised;
  2087. paranr:=nr;
  2088. paraloc[calleeside].init;
  2089. paraloc[callerside].init;
  2090. end;
  2091. destructor tparavarsym.destroy;
  2092. begin
  2093. paraloc[calleeside].done;
  2094. paraloc[callerside].done;
  2095. inherited destroy;
  2096. end;
  2097. constructor tparavarsym.ppuload(ppufile:tcompilerppufile);
  2098. begin
  2099. inherited ppuload(paravarsym,ppufile);
  2100. paranr:=ppufile.getword;
  2101. univpara:=ppufile.getboolean;
  2102. { The var state of parameter symbols is fixed after writing them so
  2103. we write them to the unit file.
  2104. This enables constant folding for inline procedures loaded from units
  2105. }
  2106. varstate:=tvarstate(ppufile.getbyte);
  2107. { read usage info }
  2108. refs:=ppufile.getbyte;
  2109. paraloc[calleeside].init;
  2110. paraloc[callerside].init;
  2111. if vo_has_explicit_paraloc in varoptions then
  2112. paraloc[callerside].ppuload(ppufile);
  2113. ppuload_platform(ppufile);
  2114. end;
  2115. procedure tparavarsym.ppuwrite(ppufile:tcompilerppufile);
  2116. var
  2117. oldintfcrc : boolean;
  2118. begin
  2119. inherited ppuwrite(ppufile);
  2120. ppufile.putword(paranr);
  2121. ppufile.putboolean(univpara);
  2122. { The var state of parameter symbols is fixed after writing them so
  2123. we write them to the unit file.
  2124. This enables constant folding for inline procedures loaded from units
  2125. }
  2126. oldintfcrc:=ppufile.do_crc;
  2127. ppufile.do_crc:=false;
  2128. ppufile.putbyte(ord(varstate));
  2129. { write also info about the usage of parameters,
  2130. the absolute usage does not matter }
  2131. ppufile.putbyte(min(1,refs));
  2132. ppufile.do_crc:=oldintfcrc;
  2133. if vo_has_explicit_paraloc in varoptions then
  2134. begin
  2135. paraloc[callerside].check_simple_location;
  2136. paraloc[callerside].ppuwrite(ppufile);
  2137. end;
  2138. writeentry(ppufile,ibparavarsym);
  2139. end;
  2140. function tparavarsym.needs_finalization:boolean;
  2141. begin
  2142. result:=(varspez=vs_value) and
  2143. (is_managed_type(vardef) or
  2144. (
  2145. (not (tabstractprocdef(owner.defowner).proccalloption in cdecl_pocalls)) and
  2146. (not paramanager.use_stackalloc) and
  2147. (is_open_array(vardef) or is_array_of_const(vardef))
  2148. )
  2149. );
  2150. end;
  2151. function tparavarsym.is_used: boolean;
  2152. begin
  2153. { Only the $parentfp parameter is supported for now }
  2154. result:=not (vo_is_parentfp in varoptions) or (varstate>vs_initialised);
  2155. end;
  2156. {****************************************************************************
  2157. TABSOLUTEVARSYM
  2158. ****************************************************************************}
  2159. constructor tabsolutevarsym.create(const n : TSymStr;def:tdef);
  2160. begin
  2161. inherited create(absolutevarsym,n,vs_value,def,[]);
  2162. ref:=nil;
  2163. end;
  2164. constructor tabsolutevarsym.create_ref(const n : TSymStr;def:tdef;_ref:tpropaccesslist);
  2165. begin
  2166. inherited create(absolutevarsym,n,vs_value,def,[]);
  2167. ref:=_ref;
  2168. end;
  2169. destructor tabsolutevarsym.destroy;
  2170. begin
  2171. if assigned(ref) then
  2172. ref.free;
  2173. inherited destroy;
  2174. end;
  2175. constructor tabsolutevarsym.ppuload(ppufile:tcompilerppufile);
  2176. begin
  2177. inherited ppuload(absolutevarsym,ppufile);
  2178. ref:=nil;
  2179. asmname:=nil;
  2180. abstyp:=absolutetyp(ppufile.getbyte);
  2181. case abstyp of
  2182. tovar :
  2183. ref:=ppufile.getpropaccesslist;
  2184. toasm :
  2185. asmname:=ppufile.getpshortstring;
  2186. toaddr :
  2187. addroffset:=ppufile.getpuint;
  2188. end;
  2189. ppuload_platform(ppufile);
  2190. end;
  2191. procedure tabsolutevarsym.ppuwrite(ppufile:tcompilerppufile);
  2192. begin
  2193. inherited ppuwrite(ppufile);
  2194. ppufile.putbyte(byte(abstyp));
  2195. case abstyp of
  2196. tovar :
  2197. ppufile.putpropaccesslist(ref);
  2198. toasm :
  2199. ppufile.putstring(asmname^);
  2200. toaddr :
  2201. ppufile.putpuint(addroffset);
  2202. end;
  2203. writeentry(ppufile,ibabsolutevarsym);
  2204. end;
  2205. procedure tabsolutevarsym.buildderef;
  2206. begin
  2207. inherited buildderef;
  2208. if (abstyp=tovar) then
  2209. ref.buildderef;
  2210. end;
  2211. procedure tabsolutevarsym.deref;
  2212. begin
  2213. inherited deref;
  2214. { own absolute deref }
  2215. if (abstyp=tovar) then
  2216. ref.resolve;
  2217. end;
  2218. function tabsolutevarsym.mangledname : TSymStr;
  2219. begin
  2220. case abstyp of
  2221. toasm :
  2222. mangledname:=asmname^;
  2223. toaddr :
  2224. mangledname:='$'+tostr(addroffset);
  2225. else
  2226. internalerror(200411062);
  2227. end;
  2228. end;
  2229. {****************************************************************************
  2230. TCONSTSYM
  2231. ****************************************************************************}
  2232. constructor tconstsym.create_ord(const n : TSymStr;t : tconsttyp;v : tconstexprint;def:tdef);
  2233. begin
  2234. inherited create(constsym,n);
  2235. fillchar(value, sizeof(value), #0);
  2236. consttyp:=t;
  2237. value.valueord:=v;
  2238. constdef:=def;
  2239. constdefderef.reset;
  2240. end;
  2241. constructor tconstsym.create_ordptr(const n : TSymStr;t : tconsttyp;v : tconstptruint;def:tdef);
  2242. begin
  2243. inherited create(constsym,n);
  2244. fillchar(value, sizeof(value), #0);
  2245. consttyp:=t;
  2246. value.valueordptr:=v;
  2247. constdef:=def;
  2248. constdefderef.reset;
  2249. end;
  2250. constructor tconstsym.create_ptr(const n : TSymStr;t : tconsttyp;v : pointer;def:tdef);
  2251. begin
  2252. inherited create(constsym,n);
  2253. fillchar(value, sizeof(value), #0);
  2254. consttyp:=t;
  2255. value.valueptr:=v;
  2256. constdef:=def;
  2257. constdefderef.reset;
  2258. end;
  2259. constructor tconstsym.create_string(const n : TSymStr;t : tconsttyp;str:pchar;l:longint;def: tdef);
  2260. begin
  2261. inherited create(constsym,n);
  2262. fillchar(value, sizeof(value), #0);
  2263. consttyp:=t;
  2264. value.valueptr:=str;
  2265. if assigned(def) then
  2266. constdef:=def
  2267. else
  2268. constdef:=carraydef.getreusable(cansichartype,l);
  2269. constdefderef.reset;
  2270. value.len:=l;
  2271. end;
  2272. constructor tconstsym.create_wstring(const n : TSymStr;t : tconsttyp;pw:pcompilerwidestring);
  2273. begin
  2274. inherited create(constsym,n);
  2275. fillchar(value, sizeof(value), #0);
  2276. consttyp:=t;
  2277. pcompilerwidestring(value.valueptr):=pw;
  2278. constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pw));
  2279. constdefderef.reset;
  2280. value.len:=getlengthwidestring(pw);
  2281. end;
  2282. constructor tconstsym.create_undefined(const n : TSymStr;def: tdef);
  2283. begin
  2284. inherited create(constsym,n);
  2285. fillchar(value,sizeof(value),#0);
  2286. consttyp:=constnone;
  2287. constdef:=def;
  2288. end;
  2289. constructor tconstsym.ppuload(ppufile:tcompilerppufile);
  2290. var
  2291. pd : pbestreal;
  2292. ps : pnormalset;
  2293. pc : pchar;
  2294. pw : pcompilerwidestring;
  2295. i : longint;
  2296. begin
  2297. inherited ppuload(constsym,ppufile);
  2298. constdef:=nil;
  2299. consttyp:=tconsttyp(ppufile.getbyte);
  2300. fillchar(value, sizeof(value), #0);
  2301. case consttyp of
  2302. constord :
  2303. begin
  2304. ppufile.getderef(constdefderef);
  2305. value.valueord:=ppufile.getexprint;
  2306. end;
  2307. constpointer :
  2308. begin
  2309. ppufile.getderef(constdefderef);
  2310. value.valueordptr:=ppufile.getptruint;
  2311. end;
  2312. constwstring :
  2313. begin
  2314. initwidestring(pw);
  2315. setlengthwidestring(pw,ppufile.getlongint);
  2316. { don't use getdata, because the compilerwidechars may have to
  2317. be byteswapped
  2318. }
  2319. {$if sizeof(tcompilerwidechar) = 2}
  2320. for i:=0 to pw^.len-1 do
  2321. pw^.data[i]:=ppufile.getword;
  2322. {$elseif sizeof(tcompilerwidechar) = 4}
  2323. for i:=0 to pw^.len-1 do
  2324. pw^.data[i]:=cardinal(ppufile.getlongint);
  2325. {$else}
  2326. {$error Unsupported tcompilerwidechar size}
  2327. {$endif}
  2328. pcompilerwidestring(value.valueptr):=pw;
  2329. end;
  2330. conststring,
  2331. constresourcestring :
  2332. begin
  2333. ppufile.getderef(constdefderef);
  2334. value.len:=ppufile.getlongint;
  2335. getmem(pc,value.len+1);
  2336. ppufile.getdata(pc^,value.len);
  2337. pc[value.len]:=#0;
  2338. value.valueptr:=pc;
  2339. end;
  2340. constreal :
  2341. begin
  2342. ppufile.getderef(constdefderef);
  2343. new(pd);
  2344. pd^:=ppufile.getreal;
  2345. value.valueptr:=pd;
  2346. end;
  2347. constset :
  2348. begin
  2349. ppufile.getderef(constdefderef);
  2350. new(ps);
  2351. ppufile.getset(tppuset32(ps^));
  2352. value.valueptr:=ps;
  2353. end;
  2354. constguid :
  2355. begin
  2356. ppufile.getderef(constdefderef);
  2357. new(pguid(value.valueptr));
  2358. ppufile.getdata(value.valueptr^,sizeof(tguid));
  2359. end;
  2360. constnil :
  2361. ppufile.getderef(constdefderef);
  2362. else
  2363. Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp)));
  2364. end;
  2365. ppuload_platform(ppufile);
  2366. end;
  2367. destructor tconstsym.destroy;
  2368. begin
  2369. case consttyp of
  2370. constnone,
  2371. constord,
  2372. constpointer,
  2373. constnil:
  2374. ;
  2375. conststring,
  2376. constresourcestring :
  2377. freemem(pchar(value.valueptr),value.len+1);
  2378. constwstring :
  2379. donewidestring(pcompilerwidestring(value.valueptr));
  2380. constreal :
  2381. dispose(pbestreal(value.valueptr));
  2382. constset :
  2383. dispose(pnormalset(value.valueptr));
  2384. constguid :
  2385. dispose(pguid(value.valueptr));
  2386. end;
  2387. inherited destroy;
  2388. end;
  2389. procedure tconstsym.buildderef;
  2390. begin
  2391. inherited;
  2392. case consttyp of
  2393. constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid:
  2394. constdefderef.build(constdef);
  2395. constwstring:
  2396. ;
  2397. else
  2398. internalerror(2015120802);
  2399. end;
  2400. end;
  2401. procedure tconstsym.deref;
  2402. begin
  2403. case consttyp of
  2404. constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid:
  2405. constdef:=tdef(constdefderef.resolve);
  2406. constwstring:
  2407. constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr)));
  2408. else
  2409. internalerror(2015120801);
  2410. end
  2411. end;
  2412. procedure tconstsym.ppuwrite(ppufile:tcompilerppufile);
  2413. begin
  2414. inherited ppuwrite(ppufile);
  2415. ppufile.putbyte(byte(consttyp));
  2416. case consttyp of
  2417. constnil :
  2418. ppufile.putderef(constdefderef);
  2419. constord :
  2420. begin
  2421. ppufile.putderef(constdefderef);
  2422. ppufile.putexprint(value.valueord);
  2423. end;
  2424. constpointer :
  2425. begin
  2426. ppufile.putderef(constdefderef);
  2427. ppufile.putptruint(value.valueordptr);
  2428. end;
  2429. constwstring :
  2430. begin
  2431. { no need to store the def, we can reconstruct it }
  2432. ppufile.putlongint(getlengthwidestring(pcompilerwidestring(value.valueptr)));
  2433. ppufile.putdata(pcompilerwidestring(value.valueptr)^.data^,pcompilerwidestring(value.valueptr)^.len*sizeof(tcompilerwidechar));
  2434. end;
  2435. conststring,
  2436. constresourcestring :
  2437. begin
  2438. ppufile.putderef(constdefderef);
  2439. ppufile.putlongint(value.len);
  2440. ppufile.putdata(pchar(value.valueptr)^,value.len);
  2441. end;
  2442. constreal :
  2443. begin
  2444. ppufile.putderef(constdefderef);
  2445. ppufile.putreal(pbestreal(value.valueptr)^);
  2446. end;
  2447. constset :
  2448. begin
  2449. ppufile.putderef(constdefderef);
  2450. ppufile.putset(tppuset32(value.valueptr^));
  2451. end;
  2452. constguid :
  2453. begin
  2454. ppufile.putderef(constdefderef);
  2455. ppufile.putdata(value.valueptr^,sizeof(tguid));
  2456. end;
  2457. else
  2458. internalerror(13);
  2459. end;
  2460. writeentry(ppufile,ibconstsym);
  2461. end;
  2462. {$ifdef DEBUG_NODE_XML}
  2463. procedure TConstSym.XMLPrintConstData(var T: Text);
  2464. begin
  2465. WriteLn(T, PrintNodeIndention, '<type>', SanitiseXMLString(constdef.GetTypeName), '</type>');
  2466. case consttyp of
  2467. constnone:
  2468. ;
  2469. conststring,
  2470. constresourcestring,
  2471. constwstring:
  2472. begin
  2473. WriteLn(T, PrintNodeIndention, '<length>', value.len, '</length>');
  2474. if value.len = 0 then
  2475. WriteLn(T, PrintNodeIndention, '<value />')
  2476. else
  2477. WriteLn(T, PrintNodeIndention, '<value>', SanitiseXMLString(PChar(value.valueptr)), '</value>');
  2478. end;
  2479. constord,
  2480. constset:
  2481. WriteLn(T, PrintNodeIndention, '<value>', tostr(value.valueord), '</value>');
  2482. constpointer:
  2483. WriteLn(T, PrintNodeIndention, '<value>', WriteConstPUInt(value.valueordptr), '</value>');
  2484. constreal:
  2485. WriteLn(T, PrintNodeIndention, '<value>', PBestReal(value.valueptr)^, '</value>');
  2486. constnil:
  2487. WriteLn(T, PrintNodeIndention, '<value>nil</value>');
  2488. constguid:
  2489. WriteLn(T, PrintNodeIndention, '<value>', WriteGUID(PGUID(value.valueptr)^), '</value>');
  2490. end;
  2491. WriteLn(T, PrintNodeIndention, '<visibility>', visibility, '</visibility>');
  2492. if not (consttyp in [conststring, constresourcestring, constwstring]) then
  2493. { constdef.size will return an internal error for string
  2494. constants because constdef is an open array internally }
  2495. WriteLn(T, PrintNodeIndention, '<size>', constdef.size, '</size>');
  2496. // WriteLn(T, PrintNodeIndention, '<const_type>', consttyp, '</const_type>');
  2497. end;
  2498. {$endif DEBUG_NODE_XML}
  2499. {****************************************************************************
  2500. TENUMSYM
  2501. ****************************************************************************}
  2502. constructor tenumsym.create(const n : TSymStr;def : tenumdef;v : longint);
  2503. begin
  2504. inherited create(enumsym,n);
  2505. definition:=def;
  2506. definitionderef.reset;
  2507. value:=v;
  2508. end;
  2509. constructor tenumsym.ppuload(ppufile:tcompilerppufile);
  2510. begin
  2511. inherited ppuload(enumsym,ppufile);
  2512. ppufile.getderef(definitionderef);
  2513. value:=ppufile.getlongint;
  2514. ppuload_platform(ppufile);
  2515. end;
  2516. procedure tenumsym.buildderef;
  2517. begin
  2518. inherited;
  2519. definitionderef.build(definition);
  2520. end;
  2521. procedure tenumsym.deref;
  2522. begin
  2523. definition:=tenumdef(definitionderef.resolve);
  2524. end;
  2525. procedure tenumsym.ppuwrite(ppufile:tcompilerppufile);
  2526. begin
  2527. inherited ppuwrite(ppufile);
  2528. ppufile.putderef(definitionderef);
  2529. ppufile.putlongint(value);
  2530. writeentry(ppufile,ibenumsym);
  2531. end;
  2532. {****************************************************************************
  2533. TTYPESYM
  2534. ****************************************************************************}
  2535. constructor ttypesym.create(const n : TSymStr;def:tdef);
  2536. begin
  2537. inherited create(typesym,n);
  2538. typedef:=def;
  2539. typedefderef.reset;
  2540. { register the typesym for the definition }
  2541. if assigned(typedef) and
  2542. (typedef.typ<>errordef) and
  2543. not(assigned(typedef.typesym)) then
  2544. typedef.typesym:=self;
  2545. end;
  2546. destructor ttypesym.destroy;
  2547. begin
  2548. inherited destroy;
  2549. end;
  2550. constructor ttypesym.ppuload(ppufile:tcompilerppufile);
  2551. begin
  2552. inherited ppuload(typesym,ppufile);
  2553. ppufile.getderef(typedefderef);
  2554. fprettyname:=ppufile.getansistring;
  2555. ppuload_platform(ppufile);
  2556. end;
  2557. procedure ttypesym.buildderef;
  2558. begin
  2559. inherited;
  2560. typedefderef.build(typedef);
  2561. end;
  2562. procedure ttypesym.deref;
  2563. begin
  2564. typedef:=tdef(typedefderef.resolve);
  2565. end;
  2566. procedure ttypesym.ppuwrite(ppufile:tcompilerppufile);
  2567. begin
  2568. inherited ppuwrite(ppufile);
  2569. ppufile.putderef(typedefderef);
  2570. ppufile.putansistring(fprettyname);
  2571. writeentry(ppufile,ibtypesym);
  2572. end;
  2573. function ttypesym.prettyname : string;
  2574. begin
  2575. if fprettyname<>'' then
  2576. result:=fprettyname
  2577. else
  2578. result:=inherited prettyname;
  2579. end;
  2580. {****************************************************************************
  2581. TSYSSYM
  2582. ****************************************************************************}
  2583. var
  2584. syssym_list : TFPHashObjectList;
  2585. constructor tsyssym.create(const n : TSymStr;l : tinlinenumber);
  2586. var
  2587. s : shortstring;
  2588. begin
  2589. inherited create(syssym,n);
  2590. number:=l;
  2591. str(longint(l),s);
  2592. if assigned(syssym_list.find(s)) then
  2593. internalerror(2016060303);
  2594. syssym_list.add(s,self);
  2595. end;
  2596. constructor tsyssym.ppuload(ppufile:tcompilerppufile);
  2597. var
  2598. s : shortstring;
  2599. begin
  2600. inherited ppuload(syssym,ppufile);
  2601. number:=tinlinenumber(ppufile.getlongint);
  2602. ppuload_platform(ppufile);
  2603. str(longint(number),s);
  2604. if assigned(syssym_list.find(s)) then
  2605. internalerror(2016060304);
  2606. syssym_list.add(s,self);
  2607. end;
  2608. destructor tsyssym.destroy;
  2609. begin
  2610. inherited destroy;
  2611. end;
  2612. procedure tsyssym.ppuwrite(ppufile:tcompilerppufile);
  2613. begin
  2614. inherited ppuwrite(ppufile);
  2615. ppufile.putlongint(longint(number));
  2616. writeentry(ppufile,ibsyssym);
  2617. end;
  2618. class function tsyssym.find_by_number(l:longint):tsyssym;
  2619. var
  2620. s : shortstring;
  2621. begin
  2622. str(l,s);
  2623. result:=tsyssym(syssym_list.find(s));
  2624. end;
  2625. {*****************************************************************************
  2626. TMacro
  2627. *****************************************************************************}
  2628. constructor tmacro.create(const n : TSymStr);
  2629. begin
  2630. inherited create(macrosym,n);
  2631. owner:=nil;
  2632. defined:=false;
  2633. is_used:=false;
  2634. is_compiler_var:=false;
  2635. buftext:=nil;
  2636. buflen:=0;
  2637. end;
  2638. constructor tmacro.ppuload(ppufile:tcompilerppufile);
  2639. begin
  2640. inherited ppuload(macrosym,ppufile);
  2641. defined:=ppufile.getboolean;
  2642. is_compiler_var:=ppufile.getboolean;
  2643. is_used:=false;
  2644. buflen:= ppufile.getlongint;
  2645. if buflen > 0 then
  2646. begin
  2647. getmem(buftext, buflen);
  2648. ppufile.getdata(buftext^, buflen)
  2649. end
  2650. else
  2651. buftext:=nil;
  2652. end;
  2653. destructor tmacro.destroy;
  2654. begin
  2655. if assigned(buftext) then
  2656. freemem(buftext);
  2657. inherited destroy;
  2658. end;
  2659. procedure tmacro.ppuwrite(ppufile:tcompilerppufile);
  2660. begin
  2661. inherited ppuwrite(ppufile);
  2662. ppufile.putboolean(defined);
  2663. ppufile.putboolean(is_compiler_var);
  2664. ppufile.putlongint(buflen);
  2665. if buflen > 0 then
  2666. ppufile.putdata(buftext^,buflen);
  2667. writeentry(ppufile,ibmacrosym);
  2668. end;
  2669. function tmacro.GetCopy:tmacro;
  2670. var
  2671. p : tmacro;
  2672. begin
  2673. p:=tmacro.create(realname);
  2674. p.defined:=defined;
  2675. p.is_used:=is_used;
  2676. p.is_compiler_var:=is_compiler_var;
  2677. p.buflen:=buflen;
  2678. if assigned(buftext) then
  2679. begin
  2680. getmem(p.buftext,buflen);
  2681. move(buftext^,p.buftext^,buflen);
  2682. end;
  2683. Result:=p;
  2684. end;
  2685. procedure init_symsym;
  2686. begin
  2687. syssym_list:=tfphashobjectlist.create(false);
  2688. end;
  2689. procedure done_symsym;
  2690. begin
  2691. syssym_list.free;
  2692. end;
  2693. initialization
  2694. register_initdone_proc(@init_symsym,@done_symsym);
  2695. end.