symsym.pas 86 KB

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