symsym.pas 83 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  4. Implementation for the symbols types of the symtable
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit symsym;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. { common }
  23. cutils,
  24. { target }
  25. cpuinfo,
  26. { symtable }
  27. symconst,symbase,symtype,symdef,
  28. { ppu }
  29. ppu,symppu,
  30. { aasm }
  31. aasmbase,aasmtai,cpubase,
  32. globals
  33. ;
  34. type
  35. {************************************************
  36. TSym
  37. ************************************************}
  38. { this object is the base for all symbol objects }
  39. tstoredsym = class(tsym)
  40. protected
  41. _mangledname : pstring;
  42. public
  43. {$ifdef GDB}
  44. isstabwritten : boolean;
  45. {$endif GDB}
  46. refs : longint;
  47. lastref,
  48. defref,
  49. lastwritten : tref;
  50. refcount : longint;
  51. constructor create(const n : string);
  52. constructor loadsym(ppufile:tcompilerppufile);
  53. destructor destroy;override;
  54. procedure write(ppufile:tcompilerppufile);virtual;abstract;
  55. procedure writesym(ppufile:tcompilerppufile);
  56. procedure deref;override;
  57. procedure insert_in_data;virtual;
  58. {$ifdef GDB}
  59. function stabstring : pchar;virtual;
  60. procedure concatstabto(asmlist : taasmoutput);virtual;
  61. {$endif GDB}
  62. procedure load_references(ppufile:tcompilerppufile;locals:boolean);virtual;
  63. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;virtual;
  64. function is_visible_for_proc(currprocdef:tprocdef):boolean;
  65. function is_visible_for_object(currobjdef:tobjectdef):boolean;
  66. function mangledname : string;
  67. procedure generate_mangledname;virtual;abstract;
  68. end;
  69. tlabelsym = class(tstoredsym)
  70. lab : tasmlabel;
  71. used,
  72. defined : boolean;
  73. code : pointer; { should be tnode }
  74. constructor create(const n : string; l : tasmlabel);
  75. destructor destroy;override;
  76. constructor load(ppufile:tcompilerppufile);
  77. procedure generate_mangledname;override;
  78. procedure write(ppufile:tcompilerppufile);override;
  79. end;
  80. tunitsym = class(tstoredsym)
  81. unitsymtable : tsymtable;
  82. prevsym : tunitsym;
  83. constructor create(const n : string;ref : tsymtable);
  84. constructor load(ppufile:tcompilerppufile);
  85. destructor destroy;override;
  86. procedure write(ppufile:tcompilerppufile);override;
  87. procedure restoreunitsym;
  88. {$ifdef GDB}
  89. procedure concatstabto(asmlist : taasmoutput);override;
  90. {$endif GDB}
  91. end;
  92. terrorsym = class(tstoredsym)
  93. constructor create;
  94. end;
  95. tprocsym = class(tstoredsym)
  96. { protected}
  97. defs : pprocdeflist; { linked list of overloaded procdefs }
  98. public
  99. is_global : boolean;
  100. overloadchecked : boolean;
  101. overloadcount : longint; { amount of overloaded functions in this module }
  102. constructor create(const n : string);
  103. constructor load(ppufile:tcompilerppufile);
  104. destructor destroy;override;
  105. { writes all declarations except the specified one }
  106. procedure write_parameter_lists(skipdef:tprocdef);
  107. { tests, if all procedures definitions are defined and not }
  108. { only forward }
  109. procedure check_forward;
  110. procedure unchain_overload;
  111. procedure write(ppufile:tcompilerppufile);override;
  112. procedure deref;override;
  113. procedure addprocdef(p:tprocdef);
  114. procedure concat_procdefs_to(s:Tprocsym);
  115. function first_procdef:Tprocdef;
  116. function last_procdef:Tprocdef;
  117. function search_procdef_bytype(pt:Tproctypeoption):Tprocdef;
  118. function search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
  119. function search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef;
  120. matchtype:Tdefmatch):Tprocdef;
  121. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override;
  122. {$ifdef GDB}
  123. function stabstring : pchar;override;
  124. procedure concatstabto(asmlist : taasmoutput);override;
  125. {$endif GDB}
  126. end;
  127. ttypesym = class(tstoredsym)
  128. restype : ttype;
  129. {$ifdef GDB}
  130. isusedinstab : boolean;
  131. {$endif GDB}
  132. constructor create(const n : string;const tt : ttype);
  133. constructor load(ppufile:tcompilerppufile);
  134. procedure write(ppufile:tcompilerppufile);override;
  135. procedure deref;override;
  136. function gettypedef:tdef;override;
  137. procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
  138. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override;
  139. {$ifdef GDB}
  140. function stabstring : pchar;override;
  141. procedure concatstabto(asmlist : taasmoutput);override;
  142. {$endif GDB}
  143. end;
  144. tvarsym = class(tstoredsym)
  145. address : longint;
  146. localvarsym : tvarsym;
  147. vartype : ttype;
  148. varoptions : tvaroptions;
  149. reg : tregister; { if reg<>R_NO, then the variable is an register variable }
  150. varspez : tvarspez; { sets the type of access }
  151. varstate : tvarstate;
  152. constructor create(const n : string;const tt : ttype);
  153. constructor create_dll(const n : string;const tt : ttype);
  154. constructor create_C(const n,mangled : string;const tt : ttype);
  155. constructor load(ppufile:tcompilerppufile);
  156. destructor destroy;override;
  157. procedure write(ppufile:tcompilerppufile);override;
  158. procedure deref;override;
  159. procedure generate_mangledname;override;
  160. procedure set_mangledname(const s:string);
  161. procedure insert_in_data;override;
  162. function getsize : longint;
  163. function getvaluesize : longint;
  164. function getpushsize : longint;
  165. {$ifdef GDB}
  166. function stabstring : pchar;override;
  167. procedure concatstabto(asmlist : taasmoutput);override;
  168. {$endif GDB}
  169. end;
  170. tpropertysym = class(tstoredsym)
  171. propoptions : tpropertyoptions;
  172. propoverriden : tpropertysym;
  173. proptype,
  174. indextype : ttype;
  175. index,
  176. default : longint;
  177. readaccess,
  178. writeaccess,
  179. storedaccess : tsymlist;
  180. constructor create(const n : string);
  181. destructor destroy;override;
  182. constructor load(ppufile:tcompilerppufile);
  183. function getsize : longint;
  184. procedure write(ppufile:tcompilerppufile);override;
  185. function gettypedef:tdef;override;
  186. procedure deref;override;
  187. procedure dooverride(overriden:tpropertysym);
  188. {$ifdef GDB}
  189. function stabstring : pchar;override;
  190. procedure concatstabto(asmlist : taasmoutput);override;
  191. {$endif GDB}
  192. end;
  193. tfuncretsym = class(tstoredsym)
  194. returntype : ttype;
  195. address : longint;
  196. funcretstate : tvarstate;
  197. constructor create(const n : string;const tt : ttype);
  198. constructor load(ppufile:tcompilerppufile);
  199. destructor destroy;override;
  200. procedure write(ppufile:tcompilerppufile);override;
  201. procedure deref;override;
  202. procedure insert_in_data;override;
  203. {$ifdef GDB}
  204. procedure concatstabto(asmlist : taasmoutput);override;
  205. {$endif GDB}
  206. end;
  207. tabsolutesym = class(tvarsym)
  208. abstyp : absolutetyp;
  209. absseg : boolean;
  210. ref : tstoredsym;
  211. asmname : pstring;
  212. constructor create(const n : string;const tt : ttype);
  213. constructor load(ppufile:tcompilerppufile);
  214. procedure deref;override;
  215. function mangledname : string;
  216. procedure write(ppufile:tcompilerppufile);override;
  217. procedure insert_in_data;override;
  218. {$ifdef GDB}
  219. procedure concatstabto(asmlist : taasmoutput);override;
  220. {$endif GDB}
  221. end;
  222. ttypedconstsym = class(tstoredsym)
  223. typedconsttype : ttype;
  224. is_writable : boolean;
  225. constructor create(const n : string;p : tdef;writable : boolean);
  226. constructor createtype(const n : string;const tt : ttype;writable : boolean);
  227. constructor load(ppufile:tcompilerppufile);
  228. destructor destroy;override;
  229. procedure generate_mangledname;override;
  230. procedure write(ppufile:tcompilerppufile);override;
  231. procedure deref;override;
  232. function getsize:longint;
  233. procedure insert_in_data;override;
  234. {$ifdef GDB}
  235. function stabstring : pchar;override;
  236. {$endif GDB}
  237. end;
  238. tconstsym = class(tstoredsym)
  239. consttype : ttype;
  240. consttyp : tconsttyp;
  241. resstrindex, { needed for resource strings }
  242. valueord : tconstexprint; { used for ordinal values }
  243. valueordptr : TConstPtrUInt; { used for pointer values }
  244. valueptr : pointer; { used for string, set, real values }
  245. len : longint; { len is needed for string length }
  246. constructor create_ord(const n : string;t : tconsttyp;v : tconstexprint);
  247. constructor create_ord_typed(const n : string;t : tconsttyp;v : tconstexprint;const tt:ttype);
  248. constructor create_ordptr_typed(const n : string;t : tconsttyp;v : tconstptruint;const tt:ttype);
  249. constructor create_ptr(const n : string;t : tconsttyp;v : pointer);
  250. constructor create_ptr_typed(const n : string;t : tconsttyp;v : pointer;const tt:ttype);
  251. constructor create_string(const n : string;t : tconsttyp;str:pchar;l:longint);
  252. constructor load(ppufile:tcompilerppufile);
  253. destructor destroy;override;
  254. function mangledname : string;
  255. procedure deref;override;
  256. procedure write(ppufile:tcompilerppufile);override;
  257. {$ifdef GDB}
  258. function stabstring : pchar;override;
  259. procedure concatstabto(asmlist : taasmoutput);override;
  260. {$endif GDB}
  261. end;
  262. tenumsym = class(tstoredsym)
  263. value : longint;
  264. definition : tenumdef;
  265. nextenum : tenumsym;
  266. constructor create(const n : string;def : tenumdef;v : longint);
  267. constructor load(ppufile:tcompilerppufile);
  268. procedure write(ppufile:tcompilerppufile);override;
  269. procedure deref;override;
  270. procedure order;
  271. {$ifdef GDB}
  272. procedure concatstabto(asmlist : taasmoutput);override;
  273. {$endif GDB}
  274. end;
  275. tsyssym = class(tstoredsym)
  276. number : longint;
  277. constructor create(const n : string;l : longint);
  278. constructor load(ppufile:tcompilerppufile);
  279. destructor destroy;override;
  280. procedure write(ppufile:tcompilerppufile);override;
  281. {$ifdef GDB}
  282. procedure concatstabto(asmlist : taasmoutput);override;
  283. {$endif GDB}
  284. end;
  285. { compiler generated symbol to point to rtti and init/finalize tables }
  286. trttisym = class(tstoredsym)
  287. lab : tasmsymbol;
  288. rttityp : trttitype;
  289. constructor create(const n:string;rt:trttitype);
  290. constructor load(ppufile:tcompilerppufile);
  291. procedure write(ppufile:tcompilerppufile);override;
  292. function mangledname:string;
  293. function get_label:tasmsymbol;
  294. end;
  295. { register variables }
  296. pregvarinfo = ^tregvarinfo;
  297. tregvarinfo = record
  298. regvars : array[1..maxvarregs] of tvarsym;
  299. regvars_para : array[1..maxvarregs] of boolean;
  300. regvars_refs : array[1..maxvarregs] of longint;
  301. fpuregvars : array[1..maxfpuvarregs] of tvarsym;
  302. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  303. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  304. end;
  305. var
  306. aktprocsym : tprocsym; { pointer to the symbol for the
  307. currently be parsed procedure }
  308. aktprocdef : tprocdef;
  309. aktcallprocdef : tabstractprocdef; { pointer to the definition of the
  310. currently called procedure,
  311. only set/unset in ncal }
  312. aktvarsym : tvarsym; { pointer to the symbol for the
  313. currently read var, only used
  314. for variable directives }
  315. generrorsym : tsym;
  316. const
  317. current_object_option : tsymoptions = [sp_public];
  318. { rtti and init/final }
  319. procedure generate_rtti(p:tsym);
  320. procedure generate_inittable(p:tsym);
  321. implementation
  322. uses
  323. {$ifdef Delphi}
  324. sysutils,
  325. {$else Delphi}
  326. strings,
  327. {$endif Delphi}
  328. { global }
  329. globtype,verbose,
  330. { target }
  331. systems,
  332. { symtable }
  333. symtable,defbase,
  334. {$ifdef GDB}
  335. gdb,
  336. {$endif GDB}
  337. { tree }
  338. node,
  339. { aasm }
  340. aasmcpu,
  341. { module }
  342. fmodule,
  343. { codegen }
  344. paramgr,cgbase,cresstr
  345. ;
  346. {****************************************************************************
  347. Helpers
  348. ****************************************************************************}
  349. {****************************************************************************
  350. TSYM (base for all symtypes)
  351. ****************************************************************************}
  352. constructor tstoredsym.create(const n : string);
  353. begin
  354. inherited create(n);
  355. symoptions:=current_object_option;
  356. {$ifdef GDB}
  357. isstabwritten := false;
  358. {$endif GDB}
  359. fileinfo:=akttokenpos;
  360. defref:=nil;
  361. refs:=0;
  362. lastwritten:=nil;
  363. refcount:=0;
  364. if (cs_browser in aktmoduleswitches) and make_ref then
  365. begin
  366. defref:=tref.create(defref,@akttokenpos);
  367. inc(refcount);
  368. end;
  369. lastref:=defref;
  370. _mangledname:=nil;
  371. end;
  372. constructor tstoredsym.loadsym(ppufile:tcompilerppufile);
  373. var
  374. s : string;
  375. nr : word;
  376. begin
  377. nr:=ppufile.getword;
  378. s:=ppufile.getstring;
  379. inherited create(s);
  380. { force the correct indexnr. must be after create! }
  381. indexnr:=nr;
  382. ppufile.getsmallset(symoptions);
  383. ppufile.getposinfo(fileinfo);
  384. lastref:=nil;
  385. defref:=nil;
  386. refs:=0;
  387. lastwritten:=nil;
  388. refcount:=0;
  389. _mangledname:=nil;
  390. {$ifdef GDB}
  391. isstabwritten := false;
  392. {$endif GDB}
  393. end;
  394. procedure tstoredsym.deref;
  395. begin
  396. end;
  397. procedure tstoredsym.load_references(ppufile:tcompilerppufile;locals:boolean);
  398. var
  399. pos : tfileposinfo;
  400. move_last : boolean;
  401. begin
  402. move_last:=lastwritten=lastref;
  403. while (not ppufile.endofentry) do
  404. begin
  405. ppufile.getposinfo(pos);
  406. inc(refcount);
  407. lastref:=tref.create(lastref,@pos);
  408. lastref.is_written:=true;
  409. if refcount=1 then
  410. defref:=lastref;
  411. end;
  412. if move_last then
  413. lastwritten:=lastref;
  414. end;
  415. { big problem here :
  416. wrong refs were written because of
  417. interface parsing of other units PM
  418. moduleindex must be checked !! }
  419. function tstoredsym.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  420. var
  421. ref : tref;
  422. symref_written,move_last : boolean;
  423. begin
  424. write_references:=false;
  425. if lastwritten=lastref then
  426. exit;
  427. { should we update lastref }
  428. move_last:=true;
  429. symref_written:=false;
  430. { write symbol refs }
  431. if assigned(lastwritten) then
  432. ref:=lastwritten
  433. else
  434. ref:=defref;
  435. while assigned(ref) do
  436. begin
  437. if ref.moduleindex=current_module.unit_index then
  438. begin
  439. { write address to this symbol }
  440. if not symref_written then
  441. begin
  442. ppufile.putderef(self);
  443. symref_written:=true;
  444. end;
  445. ppufile.putposinfo(ref.posinfo);
  446. ref.is_written:=true;
  447. if move_last then
  448. lastwritten:=ref;
  449. end
  450. else if not ref.is_written then
  451. move_last:=false
  452. else if move_last then
  453. lastwritten:=ref;
  454. ref:=ref.nextref;
  455. end;
  456. if symref_written then
  457. ppufile.writeentry(ibsymref);
  458. write_references:=symref_written;
  459. end;
  460. destructor tstoredsym.destroy;
  461. begin
  462. if assigned(_mangledname) then
  463. stringdispose(_mangledname);
  464. if assigned(defref) then
  465. begin
  466. defref.freechain;
  467. defref.free;
  468. end;
  469. inherited destroy;
  470. end;
  471. procedure tstoredsym.writesym(ppufile:tcompilerppufile);
  472. begin
  473. ppufile.putword(indexnr);
  474. ppufile.putstring(_realname^);
  475. ppufile.putsmallset(symoptions);
  476. ppufile.putposinfo(fileinfo);
  477. end;
  478. { for most symbol types there is nothing to do at all }
  479. procedure tstoredsym.insert_in_data;
  480. begin
  481. end;
  482. {$ifdef GDB}
  483. function tstoredsym.stabstring : pchar;
  484. begin
  485. stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+
  486. tostr(fileinfo.line)+',0');
  487. end;
  488. procedure tstoredsym.concatstabto(asmlist : taasmoutput);
  489. var
  490. stab_str : pchar;
  491. begin
  492. if not isstabwritten then
  493. begin
  494. stab_str := stabstring;
  495. { count_dbx(stab_str); moved to GDB.PAS }
  496. asmList.concat(Tai_stabs.Create(stab_str));
  497. isstabwritten:=true;
  498. end;
  499. end;
  500. {$endif GDB}
  501. function tstoredsym.is_visible_for_proc(currprocdef:tprocdef):boolean;
  502. begin
  503. is_visible_for_proc:=false;
  504. { private symbols are allowed when we are in the same
  505. module as they are defined }
  506. if (sp_private in symoptions) and
  507. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  508. (owner.defowner.owner.unitid<>0) then
  509. exit;
  510. { protected symbols are vissible in the module that defines them and
  511. also visible to related objects }
  512. if (sp_protected in symoptions) and
  513. (
  514. (
  515. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  516. (owner.defowner.owner.unitid<>0)
  517. ) and
  518. not(
  519. assigned(currprocdef) and
  520. assigned(currprocdef._class) and
  521. currprocdef._class.is_related(tobjectdef(owner.defowner))
  522. )
  523. ) then
  524. exit;
  525. is_visible_for_proc:=true;
  526. end;
  527. function tstoredsym.is_visible_for_object(currobjdef:tobjectdef):boolean;
  528. begin
  529. is_visible_for_object:=false;
  530. { private symbols are allowed when we are in the same
  531. module as they are defined }
  532. if (sp_private in symoptions) and
  533. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  534. (owner.defowner.owner.unitid<>0) then
  535. exit;
  536. { protected symbols are vissible in the module that defines them and
  537. also visible to related objects }
  538. if (sp_protected in symoptions) and
  539. (
  540. (
  541. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  542. (owner.defowner.owner.unitid<>0)
  543. ) and
  544. not(
  545. assigned(currobjdef) and
  546. currobjdef.is_related(tobjectdef(owner.defowner))
  547. )
  548. ) then
  549. exit;
  550. is_visible_for_object:=true;
  551. end;
  552. function tstoredsym.mangledname : string;
  553. begin
  554. if not assigned(_mangledname) then
  555. begin
  556. generate_mangledname;
  557. if not assigned(_mangledname) then
  558. internalerror(200204171);
  559. end;
  560. mangledname:=_mangledname^
  561. end;
  562. {****************************************************************************
  563. TLABELSYM
  564. ****************************************************************************}
  565. constructor tlabelsym.create(const n : string; l : tasmlabel);
  566. begin
  567. inherited create(n);
  568. typ:=labelsym;
  569. lab:=l;
  570. used:=false;
  571. defined:=false;
  572. code:=nil;
  573. end;
  574. constructor tlabelsym.load(ppufile:tcompilerppufile);
  575. begin
  576. inherited loadsym(ppufile);
  577. typ:=labelsym;
  578. { this is all dummy
  579. it is only used for local browsing }
  580. lab:=nil;
  581. code:=nil;
  582. used:=false;
  583. defined:=true;
  584. end;
  585. destructor tlabelsym.destroy;
  586. begin
  587. inherited destroy;
  588. end;
  589. procedure tlabelsym.generate_mangledname;
  590. begin
  591. _mangledname:=stringdup(lab.name);
  592. end;
  593. procedure tlabelsym.write(ppufile:tcompilerppufile);
  594. begin
  595. if owner.symtabletype=globalsymtable then
  596. Message(sym_e_ill_label_decl)
  597. else
  598. begin
  599. inherited writesym(ppufile);
  600. ppufile.writeentry(iblabelsym);
  601. end;
  602. end;
  603. {****************************************************************************
  604. TUNITSYM
  605. ****************************************************************************}
  606. constructor tunitsym.create(const n : string;ref : tsymtable);
  607. var
  608. old_make_ref : boolean;
  609. begin
  610. old_make_ref:=make_ref;
  611. make_ref:=false;
  612. inherited create(n);
  613. make_ref:=old_make_ref;
  614. typ:=unitsym;
  615. unitsymtable:=ref;
  616. if assigned(ref) and
  617. (ref.symtabletype=globalsymtable) then
  618. begin
  619. prevsym:=tglobalsymtable(ref).unitsym;
  620. tglobalsymtable(ref).unitsym:=self;
  621. end;
  622. end;
  623. constructor tunitsym.load(ppufile:tcompilerppufile);
  624. begin
  625. inherited loadsym(ppufile);
  626. typ:=unitsym;
  627. unitsymtable:=nil;
  628. prevsym:=nil;
  629. refs:=0;
  630. end;
  631. { we need to remove it from the prevsym chain ! }
  632. procedure tunitsym.restoreunitsym;
  633. var pus,ppus : tunitsym;
  634. begin
  635. if assigned(unitsymtable) and
  636. (unitsymtable.symtabletype=globalsymtable) then
  637. begin
  638. ppus:=nil;
  639. pus:=tglobalsymtable(unitsymtable).unitsym;
  640. if pus=self then
  641. tglobalsymtable(unitsymtable).unitsym:=prevsym
  642. else while assigned(pus) do
  643. begin
  644. if pus=self then
  645. begin
  646. ppus.prevsym:=prevsym;
  647. break;
  648. end
  649. else
  650. begin
  651. ppus:=pus;
  652. pus:=ppus.prevsym;
  653. end;
  654. end;
  655. end;
  656. unitsymtable:=nil;
  657. prevsym:=nil;
  658. end;
  659. destructor tunitsym.destroy;
  660. begin
  661. restoreunitsym;
  662. inherited destroy;
  663. end;
  664. procedure tunitsym.write(ppufile:tcompilerppufile);
  665. begin
  666. inherited writesym(ppufile);
  667. ppufile.writeentry(ibunitsym);
  668. end;
  669. {$ifdef GDB}
  670. procedure tunitsym.concatstabto(asmlist : taasmoutput);
  671. begin
  672. {Nothing to write to stabs !}
  673. end;
  674. {$endif GDB}
  675. {****************************************************************************
  676. TPROCSYM
  677. ****************************************************************************}
  678. constructor tprocsym.create(const n : string);
  679. begin
  680. inherited create(n);
  681. typ:=procsym;
  682. defs:=nil;
  683. owner:=nil;
  684. is_global:=false;
  685. overloadchecked:=false;
  686. overloadcount:=0;
  687. end;
  688. constructor tprocsym.load(ppufile:tcompilerppufile);
  689. var
  690. pd : tprocdef;
  691. begin
  692. inherited loadsym(ppufile);
  693. typ:=procsym;
  694. defs:=nil;
  695. repeat
  696. pd:=tprocdef(ppufile.getderef);
  697. if pd=nil then
  698. break;
  699. addprocdef(pd);
  700. until false;
  701. is_global:=false;
  702. overloadchecked:=false;
  703. overloadcount:=-1; { invalid, not used anymore }
  704. end;
  705. destructor tprocsym.destroy;
  706. var
  707. hp,p : pprocdeflist;
  708. begin
  709. p:=defs;
  710. while assigned(p) do
  711. begin
  712. hp:=p^.next;
  713. dispose(p);
  714. p:=hp;
  715. end;
  716. inherited destroy;
  717. end;
  718. procedure tprocsym.write_parameter_lists(skipdef:tprocdef);
  719. var
  720. p : pprocdeflist;
  721. begin
  722. p:=defs;
  723. while assigned(p) do
  724. begin
  725. if p^.def<>skipdef then
  726. MessagePos1(p^.def.fileinfo,sym_b_param_list,p^.def.fullprocname);
  727. p:=p^.next;
  728. end;
  729. end;
  730. procedure tprocsym.check_forward;
  731. var
  732. p : pprocdeflist;
  733. begin
  734. p:=defs;
  735. while assigned(p) do
  736. begin
  737. if (p^.def.procsym=self) and
  738. (p^.def.forwarddef) then
  739. begin
  740. MessagePos1(fileinfo,sym_e_forward_not_resolved,p^.def.fullprocname);
  741. { Turn futher error messages off }
  742. p^.def.forwarddef:=false;
  743. end;
  744. p:=p^.next;
  745. end;
  746. end;
  747. procedure tprocsym.deref;
  748. var
  749. p : pprocdeflist;
  750. begin
  751. p:=defs;
  752. while assigned(p) do
  753. begin
  754. resolvedef(pointer(p^.def));
  755. p:=p^.next;
  756. end;
  757. end;
  758. procedure tprocsym.addprocdef(p:tprocdef);
  759. var
  760. pd : pprocdeflist;
  761. begin
  762. new(pd);
  763. pd^.def:=p;
  764. pd^.next:=defs;
  765. defs:=pd;
  766. end;
  767. procedure Tprocsym.concat_procdefs_to(s:Tprocsym);
  768. var pd:Pprocdeflist;
  769. begin
  770. pd:=defs;
  771. while assigned(defs) do
  772. begin
  773. s.addprocdef(pd^.def);
  774. pd:=pd^.next;
  775. end;
  776. end;
  777. function Tprocsym.first_procdef:Tprocdef;
  778. begin
  779. first_procdef:=defs^.def;
  780. end;
  781. function Tprocsym.last_procdef:Tprocdef;
  782. var pd:Pprocdeflist;
  783. begin
  784. pd:=defs;
  785. while assigned(pd) do
  786. begin
  787. last_procdef:=pd^.def;
  788. pd:=pd^.next;
  789. end;
  790. end;
  791. function Tprocsym.search_procdef_bytype(pt:Tproctypeoption):Tprocdef;
  792. var p:Pprocdeflist;
  793. begin
  794. search_procdef_bytype:=nil;
  795. p:=defs;
  796. while p<>nil do
  797. begin
  798. if p^.def.proctypeoption=pt then
  799. begin
  800. search_procdef_bytype:=p^.def;
  801. break;
  802. end;
  803. p:=p^.next;
  804. end;
  805. end;
  806. function Tprocsym.search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
  807. var pd:Pprocdeflist;
  808. begin
  809. {This function will return the pprocdef of pprocsym that
  810. is the best match for procvardef. When there are multiple
  811. matches it returns nil.}
  812. {Try to find an exact match first.}
  813. search_procdef_byprocvardef:=nil;
  814. pd:=defs;
  815. while assigned(pd) do
  816. begin
  817. if proc_to_procvar_equal(pd^.def,d,true) then
  818. begin
  819. { already found a match ? Then stop and return nil }
  820. if assigned(search_procdef_byprocvardef) then
  821. begin
  822. search_procdef_byprocvardef:=nil;
  823. break;
  824. end;
  825. search_procdef_byprocvardef:=pd^.def;
  826. end;
  827. pd:=pd^.next;
  828. end;
  829. {Try a convertable match, if no exact match was found.}
  830. if not assigned(search_procdef_byprocvardef) and not assigned(pd) then
  831. begin
  832. pd:=defs;
  833. while assigned(pd) do
  834. begin
  835. if proc_to_procvar_equal(pd^.def,d,false) then
  836. begin
  837. { already found a match ? Then stop and return nil }
  838. if assigned(search_procdef_byprocvardef) then
  839. begin
  840. search_procdef_byprocvardef:=nil;
  841. break;
  842. end;
  843. search_procdef_byprocvardef:=pd^.def;
  844. end;
  845. pd:=pd^.next;
  846. end;
  847. end;
  848. end;
  849. function Tprocsym.search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef;
  850. matchtype:Tdefmatch):Tprocdef;
  851. var pd:Pprocdeflist;
  852. convtyp:Tconverttype;
  853. a,b:boolean;
  854. begin
  855. search_procdef_byretdef_by1paradef:=nil;
  856. pd:=defs;
  857. while assigned(pd) do
  858. begin
  859. a:=is_equal(retdef,pd^.def.rettype.def);
  860. if a then
  861. case matchtype of
  862. dm_exact:
  863. b:=TParaItem(pd^.def.para.first).paratype.def=firstpara;
  864. dm_equal:
  865. b:=is_equal(Tparaitem(pd^.def.para.first).paratype.def,firstpara);
  866. dm_convertl1:
  867. b:=isconvertable(firstpara,Tparaitem(pd^.def.para.first).paratype.def,
  868. convtyp,ordconstn,false)=1;
  869. end;
  870. if a and b then
  871. begin
  872. search_procdef_byretdef_by1paradef:=pd^.def;
  873. break;
  874. end;
  875. pd:=pd^.next;
  876. end;
  877. end;
  878. procedure tprocsym.write(ppufile:tcompilerppufile);
  879. var
  880. p : pprocdeflist;
  881. begin
  882. inherited writesym(ppufile);
  883. p:=defs;
  884. while assigned(p) do
  885. begin
  886. { only write the proc definitions that belong
  887. to this procsym }
  888. if (p^.def.procsym=self) then
  889. ppufile.putderef(p^.def);
  890. p:=p^.next;
  891. end;
  892. ppufile.putderef(nil);
  893. ppufile.writeentry(ibprocsym);
  894. end;
  895. function tprocsym.write_references(ppufile:tcompilerppufile;locals:boolean) : boolean;
  896. var
  897. p : pprocdeflist;
  898. begin
  899. write_references:=false;
  900. if not inherited write_references(ppufile,locals) then
  901. exit;
  902. write_references:=true;
  903. p:=defs;
  904. while assigned(p) do
  905. begin
  906. if (p^.def.procsym=self) then
  907. p^.def.write_references(ppufile,locals);
  908. p:=p^.next;
  909. end;
  910. end;
  911. procedure tprocsym.unchain_overload;
  912. var
  913. p,hp,
  914. first,
  915. last : pprocdeflist;
  916. begin
  917. { remove all overloaded procdefs from the
  918. procdeflist that are not in the current symtable }
  919. first:=nil;
  920. last:=nil;
  921. p:=defs;
  922. while assigned(p) do
  923. begin
  924. hp:=p^.next;
  925. if (p^.def.procsym=self) then
  926. begin
  927. { keep in list }
  928. if not assigned(first) then
  929. begin
  930. first:=p;
  931. last:=p;
  932. end
  933. else
  934. last^.next:=p;
  935. last:=p;
  936. p^.next:=nil;
  937. end
  938. else
  939. begin
  940. { remove }
  941. dispose(p);
  942. end;
  943. p:=hp;
  944. end;
  945. defs:=first;
  946. end;
  947. {$ifdef GDB}
  948. function tprocsym.stabstring : pchar;
  949. begin
  950. internalerror(200111171);
  951. stabstring:=nil;
  952. end;
  953. procedure tprocsym.concatstabto(asmlist : taasmoutput);
  954. begin
  955. internalerror(200111172);
  956. end;
  957. {$endif GDB}
  958. {****************************************************************************
  959. TERRORSYM
  960. ****************************************************************************}
  961. constructor terrorsym.create;
  962. begin
  963. inherited create('');
  964. typ:=errorsym;
  965. end;
  966. {****************************************************************************
  967. TPROPERTYSYM
  968. ****************************************************************************}
  969. constructor tpropertysym.create(const n : string);
  970. begin
  971. inherited create(n);
  972. typ:=propertysym;
  973. propoptions:=[];
  974. index:=0;
  975. default:=0;
  976. proptype.reset;
  977. indextype.reset;
  978. readaccess:=tsymlist.create;
  979. writeaccess:=tsymlist.create;
  980. storedaccess:=tsymlist.create;
  981. end;
  982. constructor tpropertysym.load(ppufile:tcompilerppufile);
  983. begin
  984. inherited loadsym(ppufile);
  985. typ:=propertysym;
  986. ppufile.getsmallset(propoptions);
  987. if (ppo_is_override in propoptions) then
  988. begin
  989. propoverriden:=tpropertysym(ppufile.getderef);
  990. { we need to have these objects initialized }
  991. readaccess:=tsymlist.create;
  992. writeaccess:=tsymlist.create;
  993. storedaccess:=tsymlist.create;
  994. end
  995. else
  996. begin
  997. ppufile.gettype(proptype);
  998. index:=ppufile.getlongint;
  999. default:=ppufile.getlongint;
  1000. ppufile.gettype(indextype);
  1001. readaccess:=ppufile.getsymlist;
  1002. writeaccess:=ppufile.getsymlist;
  1003. storedaccess:=ppufile.getsymlist;
  1004. end;
  1005. end;
  1006. destructor tpropertysym.destroy;
  1007. begin
  1008. readaccess.free;
  1009. writeaccess.free;
  1010. storedaccess.free;
  1011. inherited destroy;
  1012. end;
  1013. function tpropertysym.gettypedef:tdef;
  1014. begin
  1015. gettypedef:=proptype.def;
  1016. end;
  1017. procedure tpropertysym.deref;
  1018. begin
  1019. if (ppo_is_override in propoptions) then
  1020. begin
  1021. resolvesym(pointer(propoverriden));
  1022. dooverride(propoverriden);
  1023. end
  1024. else
  1025. begin
  1026. proptype.resolve;
  1027. indextype.resolve;
  1028. readaccess.resolve;
  1029. writeaccess.resolve;
  1030. storedaccess.resolve;
  1031. end;
  1032. end;
  1033. function tpropertysym.getsize : longint;
  1034. begin
  1035. getsize:=0;
  1036. end;
  1037. procedure tpropertysym.write(ppufile:tcompilerppufile);
  1038. begin
  1039. inherited writesym(ppufile);
  1040. ppufile.putsmallset(propoptions);
  1041. if (ppo_is_override in propoptions) then
  1042. ppufile.putderef(propoverriden)
  1043. else
  1044. begin
  1045. ppufile.puttype(proptype);
  1046. ppufile.putlongint(index);
  1047. ppufile.putlongint(default);
  1048. ppufile.puttype(indextype);
  1049. ppufile.putsymlist(readaccess);
  1050. ppufile.putsymlist(writeaccess);
  1051. ppufile.putsymlist(storedaccess);
  1052. end;
  1053. ppufile.writeentry(ibpropertysym);
  1054. end;
  1055. procedure tpropertysym.dooverride(overriden:tpropertysym);
  1056. begin
  1057. propoverriden:=overriden;
  1058. proptype:=overriden.proptype;
  1059. propoptions:=overriden.propoptions+[ppo_is_override];
  1060. index:=overriden.index;
  1061. default:=overriden.default;
  1062. indextype:=overriden.indextype;
  1063. readaccess.free;
  1064. readaccess:=overriden.readaccess.getcopy;
  1065. writeaccess.free;
  1066. writeaccess:=overriden.writeaccess.getcopy;
  1067. storedaccess.free;
  1068. storedaccess:=overriden.storedaccess.getcopy;
  1069. end;
  1070. {$ifdef GDB}
  1071. function tpropertysym.stabstring : pchar;
  1072. begin
  1073. { !!!! don't know how to handle }
  1074. stabstring:=strpnew('');
  1075. end;
  1076. procedure tpropertysym.concatstabto(asmlist : taasmoutput);
  1077. begin
  1078. { !!!! don't know how to handle }
  1079. end;
  1080. {$endif GDB}
  1081. {****************************************************************************
  1082. TFUNCRETSYM
  1083. ****************************************************************************}
  1084. constructor tfuncretsym.create(const n : string;const tt:ttype);
  1085. begin
  1086. inherited create(n);
  1087. typ:=funcretsym;
  1088. returntype:=tt;
  1089. funcretstate:=vs_declared;
  1090. { address valid for ret in param only }
  1091. { otherwise set by insert }
  1092. address:=pprocinfo(procinfo)^.return_offset;
  1093. end;
  1094. constructor tfuncretsym.load(ppufile:tcompilerppufile);
  1095. begin
  1096. inherited loadsym(ppufile);
  1097. ppufile.gettype(returntype);
  1098. address:=ppufile.getlongint;
  1099. typ:=funcretsym;
  1100. end;
  1101. destructor tfuncretsym.destroy;
  1102. begin
  1103. inherited destroy;
  1104. end;
  1105. procedure tfuncretsym.write(ppufile:tcompilerppufile);
  1106. begin
  1107. inherited writesym(ppufile);
  1108. ppufile.puttype(returntype);
  1109. ppufile.putlongint(address);
  1110. ppufile.writeentry(ibfuncretsym);
  1111. funcretstate:=vs_used;
  1112. end;
  1113. procedure tfuncretsym.deref;
  1114. begin
  1115. returntype.resolve;
  1116. end;
  1117. {$ifdef GDB}
  1118. procedure tfuncretsym.concatstabto(asmlist : taasmoutput);
  1119. begin
  1120. { Nothing to do here, it is done in genexitcode }
  1121. end;
  1122. {$endif GDB}
  1123. procedure tfuncretsym.insert_in_data;
  1124. var
  1125. varalign,l : longint;
  1126. begin
  1127. { if retoffset is already set then reuse it, this is needed
  1128. when inserting the result variable }
  1129. if procinfo^.return_offset<>0 then
  1130. address:=procinfo^.return_offset
  1131. else
  1132. begin
  1133. { allocate space in local if ret in acc or in fpu }
  1134. if paramanager.ret_in_acc(returntype.def) or
  1135. (returntype.def.deftype=floatdef) then
  1136. begin
  1137. l:=returntype.def.size;
  1138. varalign:=size_2_align(l);
  1139. varalign:=used_align(varalign,aktalignment.localalignmin,owner.dataalignment);
  1140. address:=align(owner.datasize+l,varalign);
  1141. owner.datasize:=address;
  1142. procinfo^.return_offset:=-address;
  1143. end;
  1144. end;
  1145. end;
  1146. {****************************************************************************
  1147. TABSOLUTESYM
  1148. ****************************************************************************}
  1149. constructor tabsolutesym.create(const n : string;const tt : ttype);
  1150. begin
  1151. inherited create(n,tt);
  1152. typ:=absolutesym;
  1153. end;
  1154. constructor tabsolutesym.load(ppufile:tcompilerppufile);
  1155. begin
  1156. { Note: This needs to load everything of tvarsym.write }
  1157. inherited load(ppufile);
  1158. { load absolute }
  1159. typ:=absolutesym;
  1160. ref:=nil;
  1161. address:=0;
  1162. asmname:=nil;
  1163. abstyp:=absolutetyp(ppufile.getbyte);
  1164. absseg:=false;
  1165. case abstyp of
  1166. tovar :
  1167. asmname:=stringdup(ppufile.getstring);
  1168. toasm :
  1169. asmname:=stringdup(ppufile.getstring);
  1170. toaddr :
  1171. begin
  1172. address:=ppufile.getlongint;
  1173. absseg:=boolean(ppufile.getbyte);
  1174. end;
  1175. end;
  1176. end;
  1177. procedure tabsolutesym.write(ppufile:tcompilerppufile);
  1178. var
  1179. hvo : tvaroptions;
  1180. begin
  1181. { Note: This needs to write everything of tvarsym.write }
  1182. inherited writesym(ppufile);
  1183. ppufile.putbyte(byte(varspez));
  1184. if read_member then
  1185. ppufile.putlongint(address);
  1186. { write only definition or definitionsym }
  1187. ppufile.puttype(vartype);
  1188. hvo:=varoptions-[vo_regable];
  1189. ppufile.putsmallset(hvo);
  1190. ppufile.putbyte(byte(abstyp));
  1191. case abstyp of
  1192. tovar :
  1193. ppufile.putstring(ref.name);
  1194. toasm :
  1195. ppufile.putstring(asmname^);
  1196. toaddr :
  1197. begin
  1198. ppufile.putlongint(address);
  1199. ppufile.putbyte(byte(absseg));
  1200. end;
  1201. end;
  1202. ppufile.writeentry(ibabsolutesym);
  1203. end;
  1204. procedure tabsolutesym.deref;
  1205. var
  1206. srsym : tsym;
  1207. srsymtable : tsymtable;
  1208. begin
  1209. { inheritance of varsym.deref ! }
  1210. vartype.resolve;
  1211. { own absolute deref }
  1212. if (abstyp=tovar) and (asmname<>nil) then
  1213. begin
  1214. { search previous loaded symtables }
  1215. searchsym(asmname^,srsym,srsymtable);
  1216. if not assigned(srsym) then
  1217. srsym:=searchsymonlyin(owner,asmname^);
  1218. if not assigned(srsym) then
  1219. srsym:=generrorsym;
  1220. ref:=tstoredsym(srsym);
  1221. stringdispose(asmname);
  1222. end;
  1223. end;
  1224. function tabsolutesym.mangledname : string;
  1225. begin
  1226. case abstyp of
  1227. tovar :
  1228. begin
  1229. case ref.typ of
  1230. varsym :
  1231. mangledname:=tvarsym(ref).mangledname;
  1232. else
  1233. internalerror(200111011);
  1234. end;
  1235. end;
  1236. toasm :
  1237. mangledname:=asmname^;
  1238. toaddr :
  1239. mangledname:='$'+tostr(address);
  1240. else
  1241. internalerror(10002);
  1242. end;
  1243. end;
  1244. procedure tabsolutesym.insert_in_data;
  1245. begin
  1246. end;
  1247. {$ifdef GDB}
  1248. procedure tabsolutesym.concatstabto(asmlist : taasmoutput);
  1249. begin
  1250. { I don't know how to handle this !! }
  1251. end;
  1252. {$endif GDB}
  1253. {****************************************************************************
  1254. TVARSYM
  1255. ****************************************************************************}
  1256. constructor tvarsym.create(const n : string;const tt : ttype);
  1257. begin
  1258. inherited create(n);
  1259. typ:=varsym;
  1260. vartype:=tt;
  1261. _mangledname:=nil;
  1262. varspez:=vs_value;
  1263. address:=0;
  1264. localvarsym:=nil;
  1265. refs:=0;
  1266. varstate:=vs_used;
  1267. varoptions:=[];
  1268. { can we load the value into a register ? }
  1269. if tstoreddef(tt.def).is_intregable then
  1270. include(varoptions,vo_regable)
  1271. else
  1272. exclude(varoptions,vo_regable);
  1273. if tstoreddef(tt.def).is_fpuregable then
  1274. include(varoptions,vo_fpuregable)
  1275. else
  1276. exclude(varoptions,vo_fpuregable);
  1277. reg:=R_NO;
  1278. end;
  1279. constructor tvarsym.create_dll(const n : string;const tt : ttype);
  1280. begin
  1281. tvarsym(self).create(n,tt);
  1282. include(varoptions,vo_is_dll_var);
  1283. end;
  1284. constructor tvarsym.create_C(const n,mangled : string;const tt : ttype);
  1285. begin
  1286. tvarsym(self).create(n,tt);
  1287. include(varoptions,vo_is_C_var);
  1288. stringdispose(_mangledname);
  1289. _mangledname:=stringdup(mangled);
  1290. end;
  1291. constructor tvarsym.load(ppufile:tcompilerppufile);
  1292. begin
  1293. inherited loadsym(ppufile);
  1294. typ:=varsym;
  1295. reg:=R_NO;
  1296. refs := 0;
  1297. varstate:=vs_used;
  1298. varspez:=tvarspez(ppufile.getbyte);
  1299. if read_member then
  1300. address:=ppufile.getlongint
  1301. else
  1302. address:=0;
  1303. localvarsym:=nil;
  1304. ppufile.gettype(vartype);
  1305. ppufile.getsmallset(varoptions);
  1306. if (vo_is_C_var in varoptions) then
  1307. _mangledname:=stringdup(ppufile.getstring);
  1308. end;
  1309. destructor tvarsym.destroy;
  1310. begin
  1311. inherited destroy;
  1312. end;
  1313. procedure tvarsym.deref;
  1314. begin
  1315. vartype.resolve;
  1316. end;
  1317. procedure tvarsym.write(ppufile:tcompilerppufile);
  1318. var
  1319. hvo : tvaroptions;
  1320. begin
  1321. inherited writesym(ppufile);
  1322. ppufile.putbyte(byte(varspez));
  1323. if read_member then
  1324. ppufile.putlongint(address);
  1325. ppufile.puttype(vartype);
  1326. { symbols which are load are never candidates for a register,
  1327. turn off the regable }
  1328. hvo:=varoptions-[vo_regable,vo_fpuregable];
  1329. ppufile.putsmallset(hvo);
  1330. if (vo_is_C_var in varoptions) then
  1331. ppufile.putstring(mangledname);
  1332. ppufile.writeentry(ibvarsym);
  1333. end;
  1334. procedure tvarsym.generate_mangledname;
  1335. begin
  1336. _mangledname:=stringdup(mangledname_prefix('U',owner)+name);
  1337. end;
  1338. procedure tvarsym.set_mangledname(const s:string);
  1339. begin
  1340. stringdispose(_mangledname);
  1341. _mangledname:=stringdup(s);
  1342. end;
  1343. function tvarsym.getsize : longint;
  1344. begin
  1345. if assigned(vartype.def) then
  1346. getsize:=vartype.def.size
  1347. else
  1348. getsize:=0;
  1349. end;
  1350. function tvarsym.getvaluesize : longint;
  1351. begin
  1352. if assigned(vartype.def) and
  1353. (varspez=vs_value) and
  1354. ((vartype.def.deftype<>arraydef) or
  1355. tarraydef(vartype.def).isDynamicArray or
  1356. (tarraydef(vartype.def).highrange>=tarraydef(vartype.def).lowrange)) then
  1357. getvaluesize:=vartype.def.size
  1358. else
  1359. getvaluesize:=0;
  1360. end;
  1361. function tvarsym.getpushsize : longint;
  1362. begin
  1363. if assigned(vartype.def) then
  1364. begin
  1365. case varspez of
  1366. vs_out,
  1367. vs_var :
  1368. getpushsize:=pointer_size;
  1369. vs_value,
  1370. vs_const :
  1371. begin
  1372. if paramanager.push_addr_param(vartype.def) then
  1373. getpushsize:=pointer_size
  1374. else
  1375. getpushsize:=vartype.def.size;
  1376. end;
  1377. end;
  1378. end
  1379. else
  1380. getpushsize:=0;
  1381. end;
  1382. procedure tvarsym.insert_in_data;
  1383. var
  1384. varalign,
  1385. l,modulo : longint;
  1386. storefilepos : tfileposinfo;
  1387. begin
  1388. if (vo_is_external in varoptions) then
  1389. exit;
  1390. { handle static variables of objects especially }
  1391. if read_member and (owner.symtabletype=objectsymtable) and
  1392. (sp_static in symoptions) then
  1393. begin
  1394. { the data filed is generated in parser.pas
  1395. with a tobject_FIELDNAME variable }
  1396. { this symbol can't be loaded to a register }
  1397. exclude(varoptions,vo_regable);
  1398. exclude(varoptions,vo_fpuregable);
  1399. end
  1400. else
  1401. if not(read_member) then
  1402. begin
  1403. { made problems with parameters etc. ! (FK) }
  1404. { check for instance of an abstract object or class }
  1405. {
  1406. if (tvarsym(sym).definition.deftype=objectdef) and
  1407. ((tobjectdef(tvarsym(sym).definition).options and oo_is_abstract)<>0) then
  1408. Message(sym_e_no_instance_of_abstract_object);
  1409. }
  1410. storefilepos:=aktfilepos;
  1411. aktfilepos:=akttokenpos;
  1412. if (vo_is_thread_var in varoptions) then
  1413. l:=pointer_size
  1414. else
  1415. l:=getvaluesize;
  1416. case owner.symtabletype of
  1417. stt_exceptsymtable:
  1418. { can contain only one symbol, address calculated later }
  1419. ;
  1420. localsymtable :
  1421. begin
  1422. varstate:=vs_declared;
  1423. varalign:=size_2_align(l);
  1424. varalign:=used_align(varalign,aktalignment.localalignmin,aktalignment.localalignmax);
  1425. address:=align(owner.datasize+l,varalign);
  1426. owner.datasize:=address;
  1427. end;
  1428. staticsymtable :
  1429. begin
  1430. { enable unitialized warning for local symbols }
  1431. varstate:=vs_declared;
  1432. varalign:=size_2_align(l);
  1433. varalign:=used_align(varalign,aktalignment.varalignmin,aktalignment.varalignmax);
  1434. address:=align(owner.datasize,varalign);
  1435. { insert cut for smartlinking or alignment }
  1436. if (cs_create_smart in aktmoduleswitches) then
  1437. bssSegment.concat(Tai_cut.Create)
  1438. else if (address<>owner.datasize) then
  1439. bssSegment.concat(Tai_align.create(varalign));
  1440. owner.datasize:=address+l;
  1441. {$ifdef GDB}
  1442. if cs_debuginfo in aktmoduleswitches then
  1443. concatstabto(bsssegment);
  1444. {$endif GDB}
  1445. if (cs_create_smart in aktmoduleswitches) or
  1446. DLLSource or
  1447. (vo_is_exported in varoptions) or
  1448. (vo_is_C_var in varoptions) then
  1449. bssSegment.concat(Tai_datablock.Create_global(mangledname,l))
  1450. else
  1451. bssSegment.concat(Tai_datablock.Create(mangledname,l));
  1452. {Global variables (in implementation part of course)
  1453. *can* be loaded into registers, they just may not be
  1454. accessed from procedures. The lexlevel test in nld.pas,
  1455. Tloadnode.pass_1, should take care of this.
  1456. If for some reason you think it isn't safe, try isolating
  1457. and disabling those specific cases, because small programs
  1458. without procedures can be very speed critical. For example,
  1459. think of benchmarks and programming contests. Also, new
  1460. users often test the quality of the code the compiler
  1461. generates and they do that with small programs, we should
  1462. show them the full optimizing power. (DM)}
  1463. {exclude(varoptions,vo_regable);
  1464. exclude(varoptions,vo_fpuregable);}
  1465. end;
  1466. globalsymtable :
  1467. begin
  1468. varalign:=size_2_align(l);
  1469. varalign:=used_align(varalign,aktalignment.varalignmin,aktalignment.varalignmax);
  1470. address:=align(owner.datasize,varalign);
  1471. { insert cut for smartlinking or alignment }
  1472. if (cs_create_smart in aktmoduleswitches) then
  1473. bssSegment.concat(Tai_cut.Create)
  1474. else if (address<>owner.datasize) then
  1475. bssSegment.concat(Tai_align.create(varalign));
  1476. owner.datasize:=address+l;
  1477. {$ifdef GDB}
  1478. if cs_debuginfo in aktmoduleswitches then
  1479. concatstabto(bsssegment);
  1480. {$endif GDB}
  1481. bssSegment.concat(Tai_datablock.Create_global(mangledname,l));
  1482. { this symbol can't be loaded to a register }
  1483. exclude(varoptions,vo_regable);
  1484. exclude(varoptions,vo_fpuregable);
  1485. end;
  1486. recordsymtable,
  1487. objectsymtable :
  1488. begin
  1489. { this symbol can't be loaded to a register }
  1490. exclude(varoptions,vo_regable);
  1491. exclude(varoptions,vo_fpuregable);
  1492. { get the alignment size }
  1493. if (aktalignment.recordalignmax=-1) then
  1494. begin
  1495. varalign:=vartype.def.alignment;
  1496. if (varalign>4) and ((varalign mod 4)<>0) and
  1497. (vartype.def.deftype=arraydef) then
  1498. begin
  1499. Message1(sym_w_wrong_C_pack,vartype.def.typename);
  1500. end;
  1501. if varalign=0 then
  1502. varalign:=l;
  1503. if (owner.dataalignment<aktalignment.maxCrecordalign) then
  1504. begin
  1505. if (varalign>16) and (owner.dataalignment<32) then
  1506. owner.dataalignment:=32
  1507. else if (varalign>12) and (owner.dataalignment<16) then
  1508. owner.dataalignment:=16
  1509. { 12 is needed for long double }
  1510. else if (varalign>8) and (owner.dataalignment<12) then
  1511. owner.dataalignment:=12
  1512. else if (varalign>4) and (owner.dataalignment<8) then
  1513. owner.dataalignment:=8
  1514. else if (varalign>2) and (owner.dataalignment<4) then
  1515. owner.dataalignment:=4
  1516. else if (varalign>1) and (owner.dataalignment<2) then
  1517. owner.dataalignment:=2;
  1518. end;
  1519. owner.dataalignment:=max(owner.dataalignment,aktalignment.maxCrecordalign);
  1520. end
  1521. else
  1522. varalign:=vartype.def.alignment;
  1523. if varalign=0 then
  1524. varalign:=size_2_align(l);
  1525. varalign:=used_align(varalign,aktalignment.recordalignmin,owner.dataalignment);
  1526. address:=align(owner.datasize,varalign);
  1527. owner.datasize:=address+l;
  1528. end;
  1529. parasymtable :
  1530. begin
  1531. { here we need the size of a push instead of the
  1532. size of the data }
  1533. l:=getpushsize;
  1534. varalign:=size_2_align(l);
  1535. varstate:=vs_assigned;
  1536. { we need the new datasize already aligned so we can't
  1537. use the align_address here }
  1538. address:=owner.datasize;
  1539. varalign:=used_align(varalign,owner.dataalignment,owner.dataalignment);
  1540. owner.datasize:=align(address+l,varalign);
  1541. end
  1542. else
  1543. begin
  1544. modulo:=owner.datasize and 3;
  1545. if (l>=4) and (modulo<>0) then
  1546. inc(owner.datasize,4-modulo)
  1547. else
  1548. if (l>=2) and ((modulo and 1)<>0) then
  1549. inc(owner.datasize);
  1550. address:=owner.datasize;
  1551. inc(owner.datasize,l);
  1552. end;
  1553. end;
  1554. aktfilepos:=storefilepos;
  1555. end;
  1556. end;
  1557. {$ifdef GDB}
  1558. function tvarsym.stabstring : pchar;
  1559. var
  1560. st : string;
  1561. begin
  1562. st:=tstoreddef(vartype.def).numberstring;
  1563. if (owner.symtabletype = objectsymtable) and
  1564. (sp_static in symoptions) then
  1565. begin
  1566. if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
  1567. stabstring := strpnew('"'+upper(owner.name^)+'__'+name+':'+st+
  1568. '",'+
  1569. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1570. end
  1571. else if (owner.symtabletype = globalsymtable) then
  1572. begin
  1573. { Here we used S instead of
  1574. because with G GDB doesn't look at the address field
  1575. but searches the same name or with a leading underscore
  1576. but these names don't exist in pascal !}
  1577. if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
  1578. stabstring := strpnew('"'+name+':'+st+'",'+
  1579. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1580. end
  1581. else if owner.symtabletype = staticsymtable then
  1582. begin
  1583. stabstring := strpnew('"'+name+':S'+st+'",'+
  1584. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1585. end
  1586. else if (owner.symtabletype in [parasymtable,inlineparasymtable]) then
  1587. begin
  1588. case varspez of
  1589. vs_out,
  1590. vs_var : st := 'v'+st;
  1591. vs_value,
  1592. vs_const : if paramanager.push_addr_param(vartype.def) then
  1593. st := 'v'+st { should be 'i' but 'i' doesn't work }
  1594. else
  1595. st := 'p'+st;
  1596. end;
  1597. stabstring := strpnew('"'+name+':'+st+'",'+
  1598. tostr(N_tsym)+',0,'+tostr(fileinfo.line)+','+
  1599. tostr(address+owner.address_fixup));
  1600. {offset to ebp => will not work if the framepointer is esp
  1601. so some optimizing will make things harder to debug }
  1602. end
  1603. else if (owner.symtabletype in [localsymtable,inlinelocalsymtable]) then
  1604. {$ifdef i386}
  1605. if reg<>R_NO then
  1606. begin
  1607. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1608. { this is the register order for GDB}
  1609. stabstring:=strpnew('"'+name+':r'+st+'",'+
  1610. tostr(N_RSYM)+',0,'+
  1611. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1612. end
  1613. else
  1614. {$endif i386}
  1615. { I don't know if this will work (PM) }
  1616. if (vo_is_C_var in varoptions) then
  1617. stabstring := strpnew('"'+name+':S'+st+'",'+
  1618. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname)
  1619. else
  1620. stabstring := strpnew('"'+name+':'+st+'",'+
  1621. tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address-owner.address_fixup))
  1622. else
  1623. stabstring := inherited stabstring;
  1624. end;
  1625. procedure tvarsym.concatstabto(asmlist : taasmoutput);
  1626. {$ifdef i386}
  1627. var stab_str : pchar;
  1628. {$endif i386}
  1629. begin
  1630. inherited concatstabto(asmlist);
  1631. {$ifdef i386}
  1632. if (owner.symtabletype=parasymtable) and
  1633. (reg<>R_NO) then
  1634. begin
  1635. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1636. { this is the register order for GDB}
  1637. stab_str:=strpnew('"'+name+':r'
  1638. +tstoreddef(vartype.def).numberstring+'",'+
  1639. tostr(N_RSYM)+',0,'+
  1640. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1641. asmList.concat(Tai_stabs.Create(stab_str));
  1642. end;
  1643. {$endif i386}
  1644. end;
  1645. {$endif GDB}
  1646. {****************************************************************************
  1647. TTYPEDCONSTSYM
  1648. *****************************************************************************}
  1649. constructor ttypedconstsym.create(const n : string;p : tdef;writable : boolean);
  1650. begin
  1651. inherited create(n);
  1652. typ:=typedconstsym;
  1653. typedconsttype.setdef(p);
  1654. is_writable:=writable;
  1655. end;
  1656. constructor ttypedconstsym.createtype(const n : string;const tt : ttype;writable : boolean);
  1657. begin
  1658. inherited create(n);
  1659. typ:=typedconstsym;
  1660. typedconsttype:=tt;
  1661. is_writable:=writable;
  1662. end;
  1663. constructor ttypedconstsym.load(ppufile:tcompilerppufile);
  1664. begin
  1665. inherited loadsym(ppufile);
  1666. typ:=typedconstsym;
  1667. ppufile.gettype(typedconsttype);
  1668. is_writable:=boolean(ppufile.getbyte);
  1669. end;
  1670. destructor ttypedconstsym.destroy;
  1671. begin
  1672. inherited destroy;
  1673. end;
  1674. procedure ttypedconstsym.generate_mangledname;
  1675. begin
  1676. _mangledname:=stringdup(mangledname_prefix('TC',owner)+name);
  1677. end;
  1678. function ttypedconstsym.getsize : longint;
  1679. begin
  1680. if assigned(typedconsttype.def) then
  1681. getsize:=typedconsttype.def.size
  1682. else
  1683. getsize:=0;
  1684. end;
  1685. procedure ttypedconstsym.deref;
  1686. begin
  1687. typedconsttype.resolve;
  1688. end;
  1689. procedure ttypedconstsym.write(ppufile:tcompilerppufile);
  1690. begin
  1691. inherited writesym(ppufile);
  1692. ppufile.puttype(typedconsttype);
  1693. ppufile.putbyte(byte(is_writable));
  1694. ppufile.writeentry(ibtypedconstsym);
  1695. end;
  1696. procedure ttypedconstsym.insert_in_data;
  1697. var
  1698. curconstsegment : taasmoutput;
  1699. address,l,varalign : longint;
  1700. storefilepos : tfileposinfo;
  1701. begin
  1702. storefilepos:=aktfilepos;
  1703. aktfilepos:=akttokenpos;
  1704. if is_writable then
  1705. curconstsegment:=datasegment
  1706. else
  1707. curconstsegment:=consts;
  1708. l:=getsize;
  1709. varalign:=size_2_align(l);
  1710. varalign:=used_align(varalign,aktalignment.constalignmin,aktalignment.constalignmax);
  1711. address:=align(owner.datasize,varalign);
  1712. { insert cut for smartlinking or alignment }
  1713. if (cs_create_smart in aktmoduleswitches) then
  1714. curconstSegment.concat(Tai_cut.Create)
  1715. else if (address<>owner.datasize) then
  1716. curconstSegment.concat(Tai_align.create(varalign));
  1717. owner.datasize:=address+l;
  1718. {$ifdef GDB}
  1719. if cs_debuginfo in aktmoduleswitches then
  1720. concatstabto(curconstsegment);
  1721. {$endif GDB}
  1722. if (owner.symtabletype=globalsymtable) then
  1723. begin
  1724. if (owner.unitid=0) then
  1725. curconstSegment.concat(Tai_symbol.Createdataname_global(mangledname,getsize));
  1726. end
  1727. else
  1728. begin
  1729. if (cs_create_smart in aktmoduleswitches) or
  1730. DLLSource then
  1731. curconstSegment.concat(Tai_symbol.Createdataname_global(mangledname,getsize))
  1732. else
  1733. curconstSegment.concat(Tai_symbol.Createdataname(mangledname,getsize));
  1734. end;
  1735. aktfilepos:=storefilepos;
  1736. end;
  1737. {$ifdef GDB}
  1738. function ttypedconstsym.stabstring : pchar;
  1739. var
  1740. st : char;
  1741. begin
  1742. if (cs_gdb_gsym in aktglobalswitches) and (owner.symtabletype=globalsymtable) then
  1743. st := 'G'
  1744. else
  1745. st := 'S';
  1746. stabstring := strpnew('"'+name+':'+st+
  1747. tstoreddef(typedconsttype.def).numberstring+'",'+tostr(n_STSYM)+',0,'+
  1748. tostr(fileinfo.line)+','+mangledname);
  1749. end;
  1750. {$endif GDB}
  1751. {****************************************************************************
  1752. TCONSTSYM
  1753. ****************************************************************************}
  1754. constructor tconstsym.create_ord(const n : string;t : tconsttyp;v : TConstExprInt);
  1755. begin
  1756. inherited create(n);
  1757. typ:=constsym;
  1758. consttyp:=t;
  1759. valueord:=v;
  1760. valueordptr:=0;
  1761. valueptr:=nil;
  1762. ResStrIndex:=0;
  1763. consttype.reset;
  1764. len:=0;
  1765. end;
  1766. constructor tconstsym.create_ord_typed(const n : string;t : tconsttyp;v : tconstexprint;const tt:ttype);
  1767. begin
  1768. inherited create(n);
  1769. typ:=constsym;
  1770. consttyp:=t;
  1771. valueord:=v;
  1772. valueordptr:=0;
  1773. valueptr:=nil;
  1774. ResStrIndex:=0;
  1775. consttype:=tt;
  1776. len:=0;
  1777. end;
  1778. constructor tconstsym.create_ordptr_typed(const n : string;t : tconsttyp;v : tconstptruint;const tt:ttype);
  1779. begin
  1780. inherited create(n);
  1781. typ:=constsym;
  1782. consttyp:=t;
  1783. valueord:=0;
  1784. valueordptr:=v;
  1785. valueptr:=nil;
  1786. ResStrIndex:=0;
  1787. consttype:=tt;
  1788. len:=0;
  1789. end;
  1790. constructor tconstsym.create_ptr(const n : string;t : tconsttyp;v : pointer);
  1791. begin
  1792. inherited create(n);
  1793. typ:=constsym;
  1794. consttyp:=t;
  1795. valueord:=0;
  1796. valueordptr:=0;
  1797. valueptr:=v;
  1798. ResStrIndex:=0;
  1799. consttype.reset;
  1800. len:=0;
  1801. end;
  1802. constructor tconstsym.create_ptr_typed(const n : string;t : tconsttyp;v : pointer;const tt:ttype);
  1803. begin
  1804. inherited create(n);
  1805. typ:=constsym;
  1806. consttyp:=t;
  1807. valueord:=0;
  1808. valueordptr:=0;
  1809. valueptr:=v;
  1810. ResStrIndex:=0;
  1811. consttype:=tt;
  1812. len:=0;
  1813. end;
  1814. constructor tconstsym.create_string(const n : string;t : tconsttyp;str:pchar;l:longint);
  1815. begin
  1816. inherited create(n);
  1817. typ:=constsym;
  1818. consttyp:=t;
  1819. valueord:=0;
  1820. valueordptr:=0;
  1821. valueptr:=str;
  1822. consttype.reset;
  1823. len:=l;
  1824. if t=constresourcestring then
  1825. ResStrIndex:=ResourceStrings.Register(name,pchar(valueptr),len);
  1826. end;
  1827. constructor tconstsym.load(ppufile:tcompilerppufile);
  1828. var
  1829. pd : pbestreal;
  1830. ps : pnormalset;
  1831. pc : pchar;
  1832. l1,l2 : longint;
  1833. begin
  1834. inherited loadsym(ppufile);
  1835. typ:=constsym;
  1836. consttype.reset;
  1837. consttyp:=tconsttyp(ppufile.getbyte);
  1838. valueord:=0;
  1839. valueordptr:=0;
  1840. valueptr:=nil;
  1841. case consttyp of
  1842. constint:
  1843. if sizeof(tconstexprint)=8 then
  1844. begin
  1845. l1:=ppufile.getlongint;
  1846. l2:=ppufile.getlongint;
  1847. {$ifopt R+}
  1848. {$define Range_check_on}
  1849. {$endif opt R+}
  1850. {$R- needed here }
  1851. valueord:=qword(l1)+(int64(l2) shl 32);
  1852. {$ifdef Range_check_on}
  1853. {$R+}
  1854. {$undef Range_check_on}
  1855. {$endif Range_check_on}
  1856. end
  1857. else
  1858. valueord:=ppufile.getlongint;
  1859. constwchar,
  1860. constbool,
  1861. constchar :
  1862. valueord:=ppufile.getlongint;
  1863. constord :
  1864. begin
  1865. ppufile.gettype(consttype);
  1866. if sizeof(TConstExprInt)=8 then
  1867. begin
  1868. l1:=ppufile.getlongint;
  1869. l2:=ppufile.getlongint;
  1870. {$ifopt R+}
  1871. {$define Range_check_on}
  1872. {$endif opt R+}
  1873. {$R- needed here }
  1874. valueord:=qword(l1)+(int64(l2) shl 32);
  1875. {$ifdef Range_check_on}
  1876. {$R+}
  1877. {$undef Range_check_on}
  1878. {$endif Range_check_on}
  1879. end
  1880. else
  1881. valueord:=ppufile.getlongint;
  1882. end;
  1883. constpointer :
  1884. begin
  1885. ppufile.gettype(consttype);
  1886. if sizeof(TConstPtrUInt)=8 then
  1887. begin
  1888. l1:=ppufile.getlongint;
  1889. l2:=ppufile.getlongint;
  1890. {$ifopt R+}
  1891. {$define Range_check_on}
  1892. {$endif opt R+}
  1893. {$R- needed here }
  1894. valueordptr:=qword(l1)+(int64(l2) shl 32);
  1895. {$ifdef Range_check_on}
  1896. {$R+}
  1897. {$undef Range_check_on}
  1898. {$endif Range_check_on}
  1899. end
  1900. else
  1901. valueordptr:=cardinal(ppufile.getlongint);
  1902. end;
  1903. conststring,
  1904. constresourcestring :
  1905. begin
  1906. len:=ppufile.getlongint;
  1907. getmem(pc,len+1);
  1908. ppufile.getdata(pc^,len);
  1909. if consttyp=constresourcestring then
  1910. ResStrIndex:=ppufile.getlongint;
  1911. valueptr:=pc;
  1912. end;
  1913. constreal :
  1914. begin
  1915. new(pd);
  1916. pd^:=ppufile.getreal;
  1917. valueptr:=pd;
  1918. end;
  1919. constset :
  1920. begin
  1921. ppufile.gettype(consttype);
  1922. new(ps);
  1923. ppufile.getnormalset(ps^);
  1924. valueptr:=ps;
  1925. end;
  1926. constnil : ;
  1927. else
  1928. Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp)));
  1929. end;
  1930. end;
  1931. destructor tconstsym.destroy;
  1932. begin
  1933. case consttyp of
  1934. conststring,
  1935. constresourcestring :
  1936. freemem(pchar(valueptr),len+1);
  1937. constreal :
  1938. dispose(pbestreal(valueptr));
  1939. constset :
  1940. dispose(pnormalset(valueptr));
  1941. end;
  1942. inherited destroy;
  1943. end;
  1944. function tconstsym.mangledname : string;
  1945. begin
  1946. mangledname:=name;
  1947. end;
  1948. procedure tconstsym.deref;
  1949. begin
  1950. if consttyp in [constord,constpointer,constset] then
  1951. consttype.resolve;
  1952. end;
  1953. procedure tconstsym.write(ppufile:tcompilerppufile);
  1954. begin
  1955. inherited writesym(ppufile);
  1956. ppufile.putbyte(byte(consttyp));
  1957. case consttyp of
  1958. constnil : ;
  1959. constint:
  1960. begin
  1961. if sizeof(TConstExprInt)=8 then
  1962. begin
  1963. ppufile.putlongint(longint(lo(valueord)));
  1964. ppufile.putlongint(longint(hi(valueord)));
  1965. end
  1966. else
  1967. ppufile.putlongint(valueord);
  1968. end;
  1969. constbool,
  1970. constchar :
  1971. ppufile.putlongint(valueord);
  1972. constord :
  1973. begin
  1974. ppufile.puttype(consttype);
  1975. if sizeof(TConstExprInt)=8 then
  1976. begin
  1977. ppufile.putlongint(longint(lo(valueord)));
  1978. ppufile.putlongint(longint(hi(valueord)));
  1979. end
  1980. else
  1981. ppufile.putlongint(valueord);
  1982. end;
  1983. constpointer :
  1984. begin
  1985. ppufile.puttype(consttype);
  1986. if sizeof(TConstPtrUInt)=8 then
  1987. begin
  1988. ppufile.putlongint(longint(lo(valueordptr)));
  1989. ppufile.putlongint(longint(hi(valueordptr)));
  1990. end
  1991. else
  1992. ppufile.putlongint(longint(valueordptr));
  1993. end;
  1994. conststring,
  1995. constresourcestring :
  1996. begin
  1997. ppufile.putlongint(len);
  1998. ppufile.putdata(pchar(valueptr)^,len);
  1999. if consttyp=constresourcestring then
  2000. ppufile.putlongint(ResStrIndex);
  2001. end;
  2002. constreal :
  2003. ppufile.putreal(pbestreal(valueptr)^);
  2004. constset :
  2005. begin
  2006. ppufile.puttype(consttype);
  2007. ppufile.putnormalset(valueptr^);
  2008. end;
  2009. else
  2010. internalerror(13);
  2011. end;
  2012. ppufile.writeentry(ibconstsym);
  2013. end;
  2014. {$ifdef GDB}
  2015. function tconstsym.stabstring : pchar;
  2016. var st : string;
  2017. begin
  2018. {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
  2019. case consttyp of
  2020. conststring : begin
  2021. st := 's'''+strpas(pchar(valueptr))+'''';
  2022. end;
  2023. constbool,
  2024. constint,
  2025. constord,
  2026. constchar : st := 'i'+int64tostr(valueord);
  2027. constpointer :
  2028. st := 'i'+int64tostr(valueordptr);
  2029. constreal : begin
  2030. system.str(pbestreal(valueptr)^,st);
  2031. st := 'r'+st;
  2032. end;
  2033. { if we don't know just put zero !! }
  2034. else st:='i0';
  2035. {***SETCONST}
  2036. {constset:;} {*** I don't know what to do with a set.}
  2037. { sets are not recognized by GDB}
  2038. {***}
  2039. end;
  2040. stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
  2041. tostr(fileinfo.line)+',0');
  2042. end;
  2043. procedure tconstsym.concatstabto(asmlist : taasmoutput);
  2044. begin
  2045. if consttyp <> conststring then
  2046. inherited concatstabto(asmlist);
  2047. end;
  2048. {$endif GDB}
  2049. {****************************************************************************
  2050. TENUMSYM
  2051. ****************************************************************************}
  2052. constructor tenumsym.create(const n : string;def : tenumdef;v : longint);
  2053. begin
  2054. inherited create(n);
  2055. typ:=enumsym;
  2056. definition:=def;
  2057. value:=v;
  2058. { check for jumps }
  2059. if v>def.max+1 then
  2060. def.has_jumps:=true;
  2061. { update low and high }
  2062. if def.min>v then
  2063. def.setmin(v);
  2064. if def.max<v then
  2065. def.setmax(v);
  2066. order;
  2067. end;
  2068. constructor tenumsym.load(ppufile:tcompilerppufile);
  2069. begin
  2070. inherited loadsym(ppufile);
  2071. typ:=enumsym;
  2072. definition:=tenumdef(ppufile.getderef);
  2073. value:=ppufile.getlongint;
  2074. nextenum := Nil;
  2075. end;
  2076. procedure tenumsym.deref;
  2077. begin
  2078. resolvedef(pointer(definition));
  2079. order;
  2080. end;
  2081. procedure tenumsym.order;
  2082. var
  2083. sym : tenumsym;
  2084. begin
  2085. sym := tenumsym(definition.firstenum);
  2086. if sym = nil then
  2087. begin
  2088. definition.firstenum := self;
  2089. nextenum := nil;
  2090. exit;
  2091. end;
  2092. { reorder the symbols in increasing value }
  2093. if value < sym.value then
  2094. begin
  2095. nextenum := sym;
  2096. definition.firstenum := self;
  2097. end
  2098. else
  2099. begin
  2100. while (sym.value <= value) and assigned(sym.nextenum) do
  2101. sym := sym.nextenum;
  2102. nextenum := sym.nextenum;
  2103. sym.nextenum := self;
  2104. end;
  2105. end;
  2106. procedure tenumsym.write(ppufile:tcompilerppufile);
  2107. begin
  2108. inherited writesym(ppufile);
  2109. ppufile.putderef(definition);
  2110. ppufile.putlongint(value);
  2111. ppufile.writeentry(ibenumsym);
  2112. end;
  2113. {$ifdef GDB}
  2114. procedure tenumsym.concatstabto(asmlist : taasmoutput);
  2115. begin
  2116. {enum elements have no stab !}
  2117. end;
  2118. {$EndIf GDB}
  2119. {****************************************************************************
  2120. TTYPESYM
  2121. ****************************************************************************}
  2122. constructor ttypesym.create(const n : string;const tt : ttype);
  2123. begin
  2124. inherited create(n);
  2125. typ:=typesym;
  2126. restype:=tt;
  2127. {$ifdef GDB}
  2128. isusedinstab := false;
  2129. {$endif GDB}
  2130. { register the typesym for the definition }
  2131. if assigned(restype.def) and
  2132. (restype.def.deftype<>errordef) and
  2133. not(assigned(restype.def.typesym)) then
  2134. restype.def.typesym:=self;
  2135. end;
  2136. constructor ttypesym.load(ppufile:tcompilerppufile);
  2137. begin
  2138. inherited loadsym(ppufile);
  2139. typ:=typesym;
  2140. {$ifdef GDB}
  2141. isusedinstab := false;
  2142. {$endif GDB}
  2143. ppufile.gettype(restype);
  2144. end;
  2145. function ttypesym.gettypedef:tdef;
  2146. begin
  2147. gettypedef:=restype.def;
  2148. end;
  2149. procedure ttypesym.deref;
  2150. begin
  2151. restype.resolve;
  2152. end;
  2153. procedure ttypesym.write(ppufile:tcompilerppufile);
  2154. begin
  2155. inherited writesym(ppufile);
  2156. ppufile.puttype(restype);
  2157. ppufile.writeentry(ibtypesym);
  2158. end;
  2159. procedure ttypesym.load_references(ppufile:tcompilerppufile;locals:boolean);
  2160. begin
  2161. inherited load_references(ppufile,locals);
  2162. if (restype.def.deftype=recorddef) then
  2163. tstoredsymtable(trecorddef(restype.def).symtable).load_references(ppufile,locals);
  2164. if (restype.def.deftype=objectdef) then
  2165. tstoredsymtable(tobjectdef(restype.def).symtable).load_references(ppufile,locals);
  2166. end;
  2167. function ttypesym.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  2168. begin
  2169. if not inherited write_references(ppufile,locals) then
  2170. begin
  2171. { write address of this symbol if record or object
  2172. even if no real refs are there
  2173. because we need it for the symtable }
  2174. if (restype.def.deftype in [recorddef,objectdef]) then
  2175. begin
  2176. ppufile.putderef(self);
  2177. ppufile.writeentry(ibsymref);
  2178. end;
  2179. end;
  2180. write_references:=true;
  2181. if (restype.def.deftype=recorddef) then
  2182. tstoredsymtable(trecorddef(restype.def).symtable).write_references(ppufile,locals);
  2183. if (restype.def.deftype=objectdef) then
  2184. tstoredsymtable(tobjectdef(restype.def).symtable).write_references(ppufile,locals);
  2185. end;
  2186. {$ifdef GDB}
  2187. function ttypesym.stabstring : pchar;
  2188. var
  2189. stabchar : string[2];
  2190. short : string;
  2191. begin
  2192. if restype.def.deftype in tagtypes then
  2193. stabchar := 'Tt'
  2194. else
  2195. stabchar := 't';
  2196. short := '"'+name+':'+stabchar+tstoreddef(restype.def).numberstring
  2197. +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
  2198. stabstring := strpnew(short);
  2199. end;
  2200. procedure ttypesym.concatstabto(asmlist : taasmoutput);
  2201. begin
  2202. {not stabs for forward defs }
  2203. if assigned(restype.def) then
  2204. if (restype.def.typesym = self) then
  2205. tstoreddef(restype.def).concatstabto(asmlist)
  2206. else
  2207. inherited concatstabto(asmlist);
  2208. end;
  2209. {$endif GDB}
  2210. {****************************************************************************
  2211. TSYSSYM
  2212. ****************************************************************************}
  2213. constructor tsyssym.create(const n : string;l : longint);
  2214. begin
  2215. inherited create(n);
  2216. typ:=syssym;
  2217. number:=l;
  2218. end;
  2219. constructor tsyssym.load(ppufile:tcompilerppufile);
  2220. begin
  2221. inherited loadsym(ppufile);
  2222. typ:=syssym;
  2223. number:=ppufile.getlongint;
  2224. end;
  2225. destructor tsyssym.destroy;
  2226. begin
  2227. inherited destroy;
  2228. end;
  2229. procedure tsyssym.write(ppufile:tcompilerppufile);
  2230. begin
  2231. inherited writesym(ppufile);
  2232. ppufile.putlongint(number);
  2233. ppufile.writeentry(ibsyssym);
  2234. end;
  2235. {$ifdef GDB}
  2236. procedure tsyssym.concatstabto(asmlist : taasmoutput);
  2237. begin
  2238. end;
  2239. {$endif GDB}
  2240. {****************************************************************************
  2241. TRTTISYM
  2242. ****************************************************************************}
  2243. constructor trttisym.create(const n:string;rt:trttitype);
  2244. const
  2245. prefix : array[trttitype] of string[5]=('$rtti','$init');
  2246. begin
  2247. inherited create(prefix[rt]+n);
  2248. typ:=rttisym;
  2249. lab:=nil;
  2250. rttityp:=rt;
  2251. end;
  2252. constructor trttisym.load(ppufile:tcompilerppufile);
  2253. begin
  2254. inherited loadsym(ppufile);
  2255. typ:=rttisym;
  2256. lab:=nil;
  2257. rttityp:=trttitype(ppufile.getbyte);
  2258. end;
  2259. procedure trttisym.write(ppufile:tcompilerppufile);
  2260. begin
  2261. inherited writesym(ppufile);
  2262. ppufile.putbyte(byte(rttityp));
  2263. ppufile.writeentry(ibrttisym);
  2264. end;
  2265. function trttisym.mangledname : string;
  2266. const
  2267. prefix : array[trttitype] of string[5]=('RTTI_','INIT_');
  2268. var
  2269. s : string;
  2270. p : tsymtable;
  2271. begin
  2272. s:='';
  2273. p:=owner;
  2274. while assigned(p) and (p.symtabletype=localsymtable) do
  2275. begin
  2276. s:=s+'_'+p.defowner.name;
  2277. p:=p.defowner.owner;
  2278. end;
  2279. if not(p.symtabletype in [globalsymtable,staticsymtable]) then
  2280. internalerror(200108265);
  2281. mangledname:=prefix[rttityp]+p.name^+s+'$_'+Copy(name,5,255);
  2282. end;
  2283. function trttisym.get_label:tasmsymbol;
  2284. begin
  2285. { the label is always a global label }
  2286. if not assigned(lab) then
  2287. lab:=newasmsymboltype(mangledname,AB_GLOBAL,AT_DATA);
  2288. get_label:=lab;
  2289. end;
  2290. { persistent rtti generation }
  2291. procedure generate_rtti(p:tsym);
  2292. var
  2293. rsym : trttisym;
  2294. def : tstoreddef;
  2295. begin
  2296. { rtti can only be generated for classes that are always typesyms }
  2297. if not(p.typ=typesym) then
  2298. internalerror(200108261);
  2299. def:=tstoreddef(ttypesym(p).restype.def);
  2300. { only create rtti once for each definition }
  2301. if not(df_has_rttitable in def.defoptions) then
  2302. begin
  2303. { definition should be in the same symtable as the symbol }
  2304. if p.owner<>def.owner then
  2305. internalerror(200108262);
  2306. { create rttisym }
  2307. rsym:=trttisym.create(p.name,fullrtti);
  2308. p.owner.insert(rsym);
  2309. { register rttisym in definition }
  2310. include(def.defoptions,df_has_rttitable);
  2311. def.rttitablesym:=rsym;
  2312. { write rtti data }
  2313. def.write_child_rtti_data(fullrtti);
  2314. if (cs_create_smart in aktmoduleswitches) then
  2315. rttiList.concat(Tai_cut.Create);
  2316. rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
  2317. def.write_rtti_data(fullrtti);
  2318. rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
  2319. end;
  2320. end;
  2321. { persistent init table generation }
  2322. procedure generate_inittable(p:tsym);
  2323. var
  2324. rsym : trttisym;
  2325. def : tstoreddef;
  2326. begin
  2327. { anonymous types are also allowed for records that can be varsym }
  2328. case p.typ of
  2329. typesym :
  2330. def:=tstoreddef(ttypesym(p).restype.def);
  2331. varsym :
  2332. def:=tstoreddef(tvarsym(p).vartype.def);
  2333. else
  2334. internalerror(200108263);
  2335. end;
  2336. { only create inittable once for each definition }
  2337. if not(df_has_inittable in def.defoptions) then
  2338. begin
  2339. { definition should be in the same symtable as the symbol }
  2340. if p.owner<>def.owner then
  2341. internalerror(200108264);
  2342. { create rttisym }
  2343. rsym:=trttisym.create(p.name,initrtti);
  2344. p.owner.insert(rsym);
  2345. { register rttisym in definition }
  2346. include(def.defoptions,df_has_inittable);
  2347. def.inittablesym:=rsym;
  2348. { write inittable data }
  2349. def.write_child_rtti_data(initrtti);
  2350. if (cs_create_smart in aktmoduleswitches) then
  2351. rttiList.concat(Tai_cut.Create);
  2352. rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
  2353. def.write_rtti_data(initrtti);
  2354. rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
  2355. end;
  2356. end;
  2357. end.
  2358. {
  2359. $Log$
  2360. Revision 1.45 2002-07-23 09:51:26 daniel
  2361. * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
  2362. are worth comitting.
  2363. Revision 1.44 2002/07/20 17:45:29 daniel
  2364. * Register variables are now possible for global variables too. This is
  2365. important for small programs without procedures.
  2366. Revision 1.43 2002/07/20 11:57:58 florian
  2367. * types.pas renamed to defbase.pas because D6 contains a types
  2368. unit so this would conflicts if D6 programms are compiled
  2369. + Willamette/SSE2 instructions to assembler added
  2370. Revision 1.42 2002/07/11 14:41:31 florian
  2371. * start of the new generic parameter handling
  2372. Revision 1.41 2002/07/10 07:24:40 jonas
  2373. * memory leak fixes from Sergey Korshunoff
  2374. Revision 1.40 2002/07/01 18:46:27 peter
  2375. * internal linker
  2376. * reorganized aasm layer
  2377. Revision 1.39 2002/05/18 13:34:18 peter
  2378. * readded missing revisions
  2379. Revision 1.38 2002/05/16 19:46:45 carl
  2380. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  2381. + try to fix temp allocation (still in ifdef)
  2382. + generic constructor calls
  2383. + start of tassembler / tmodulebase class cleanup
  2384. Revision 1.36 2002/05/12 16:53:15 peter
  2385. * moved entry and exitcode to ncgutil and cgobj
  2386. * foreach gets extra argument for passing local data to the
  2387. iterator function
  2388. * -CR checks also class typecasts at runtime by changing them
  2389. into as
  2390. * fixed compiler to cycle with the -CR option
  2391. * fixed stabs with elf writer, finally the global variables can
  2392. be watched
  2393. * removed a lot of routines from cga unit and replaced them by
  2394. calls to cgobj
  2395. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  2396. u32bit then the other is typecasted also to u32bit without giving
  2397. a rangecheck warning/error.
  2398. * fixed pascal calling method with reversing also the high tree in
  2399. the parast, detected by tcalcst3 test
  2400. Revision 1.35 2002/04/19 15:46:03 peter
  2401. * mangledname rewrite, tprocdef.mangledname is now created dynamicly
  2402. in most cases and not written to the ppu
  2403. * add mangeledname_prefix() routine to generate the prefix of
  2404. manglednames depending on the current procedure, object and module
  2405. * removed static procprefix since the mangledname is now build only
  2406. on demand from tprocdef.mangledname
  2407. Revision 1.34 2002/04/16 16:12:47 peter
  2408. * give error when using enums with jumps as array index
  2409. * allow char as enum value
  2410. Revision 1.33 2002/04/15 19:08:22 carl
  2411. + target_info.size_of_pointer -> pointer_size
  2412. + some cleanup of unused types/variables
  2413. Revision 1.32 2002/04/07 13:37:29 carl
  2414. + change unit use
  2415. Revision 1.31 2002/02/03 09:30:04 peter
  2416. * more fixes for protected handling
  2417. }