symsym.pas 83 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749
  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. {Alert alert alert alert alert alert alert!!!
  861. Make sure you never call isconvertable when a=false. You get
  862. endless recursion then. Originally a and b were placed in a
  863. single if statement. There was only one reason that it worked:
  864. short circuit boolean eval.}
  865. if a then
  866. case matchtype of
  867. dm_exact:
  868. b:=TParaItem(pd^.def.para.first).paratype.def=firstpara;
  869. dm_equal:
  870. b:=is_equal(Tparaitem(pd^.def.para.first).paratype.def,firstpara);
  871. dm_convertl1:
  872. b:=isconvertable(firstpara,Tparaitem(pd^.def.para.first).paratype.def,
  873. convtyp,ordconstn,false)=1;
  874. end;
  875. if a and b then
  876. begin
  877. search_procdef_byretdef_by1paradef:=pd^.def;
  878. break;
  879. end;
  880. pd:=pd^.next;
  881. end;
  882. end;
  883. procedure tprocsym.write(ppufile:tcompilerppufile);
  884. var
  885. p : pprocdeflist;
  886. begin
  887. inherited writesym(ppufile);
  888. p:=defs;
  889. while assigned(p) do
  890. begin
  891. { only write the proc definitions that belong
  892. to this procsym }
  893. if (p^.def.procsym=self) then
  894. ppufile.putderef(p^.def);
  895. p:=p^.next;
  896. end;
  897. ppufile.putderef(nil);
  898. ppufile.writeentry(ibprocsym);
  899. end;
  900. function tprocsym.write_references(ppufile:tcompilerppufile;locals:boolean) : boolean;
  901. var
  902. p : pprocdeflist;
  903. begin
  904. write_references:=false;
  905. if not inherited write_references(ppufile,locals) then
  906. exit;
  907. write_references:=true;
  908. p:=defs;
  909. while assigned(p) do
  910. begin
  911. if (p^.def.procsym=self) then
  912. p^.def.write_references(ppufile,locals);
  913. p:=p^.next;
  914. end;
  915. end;
  916. procedure tprocsym.unchain_overload;
  917. var
  918. p,hp,
  919. first,
  920. last : pprocdeflist;
  921. begin
  922. { remove all overloaded procdefs from the
  923. procdeflist that are not in the current symtable }
  924. first:=nil;
  925. last:=nil;
  926. p:=defs;
  927. while assigned(p) do
  928. begin
  929. hp:=p^.next;
  930. if (p^.def.procsym=self) then
  931. begin
  932. { keep in list }
  933. if not assigned(first) then
  934. begin
  935. first:=p;
  936. last:=p;
  937. end
  938. else
  939. last^.next:=p;
  940. last:=p;
  941. p^.next:=nil;
  942. end
  943. else
  944. begin
  945. { remove }
  946. dispose(p);
  947. end;
  948. p:=hp;
  949. end;
  950. defs:=first;
  951. end;
  952. {$ifdef GDB}
  953. function tprocsym.stabstring : pchar;
  954. begin
  955. internalerror(200111171);
  956. stabstring:=nil;
  957. end;
  958. procedure tprocsym.concatstabto(asmlist : taasmoutput);
  959. begin
  960. internalerror(200111172);
  961. end;
  962. {$endif GDB}
  963. {****************************************************************************
  964. TERRORSYM
  965. ****************************************************************************}
  966. constructor terrorsym.create;
  967. begin
  968. inherited create('');
  969. typ:=errorsym;
  970. end;
  971. {****************************************************************************
  972. TPROPERTYSYM
  973. ****************************************************************************}
  974. constructor tpropertysym.create(const n : string);
  975. begin
  976. inherited create(n);
  977. typ:=propertysym;
  978. propoptions:=[];
  979. index:=0;
  980. default:=0;
  981. proptype.reset;
  982. indextype.reset;
  983. readaccess:=tsymlist.create;
  984. writeaccess:=tsymlist.create;
  985. storedaccess:=tsymlist.create;
  986. end;
  987. constructor tpropertysym.load(ppufile:tcompilerppufile);
  988. begin
  989. inherited loadsym(ppufile);
  990. typ:=propertysym;
  991. ppufile.getsmallset(propoptions);
  992. if (ppo_is_override in propoptions) then
  993. begin
  994. propoverriden:=tpropertysym(ppufile.getderef);
  995. { we need to have these objects initialized }
  996. readaccess:=tsymlist.create;
  997. writeaccess:=tsymlist.create;
  998. storedaccess:=tsymlist.create;
  999. end
  1000. else
  1001. begin
  1002. ppufile.gettype(proptype);
  1003. index:=ppufile.getlongint;
  1004. default:=ppufile.getlongint;
  1005. ppufile.gettype(indextype);
  1006. readaccess:=ppufile.getsymlist;
  1007. writeaccess:=ppufile.getsymlist;
  1008. storedaccess:=ppufile.getsymlist;
  1009. end;
  1010. end;
  1011. destructor tpropertysym.destroy;
  1012. begin
  1013. readaccess.free;
  1014. writeaccess.free;
  1015. storedaccess.free;
  1016. inherited destroy;
  1017. end;
  1018. function tpropertysym.gettypedef:tdef;
  1019. begin
  1020. gettypedef:=proptype.def;
  1021. end;
  1022. procedure tpropertysym.deref;
  1023. begin
  1024. if (ppo_is_override in propoptions) then
  1025. begin
  1026. resolvesym(pointer(propoverriden));
  1027. dooverride(propoverriden);
  1028. end
  1029. else
  1030. begin
  1031. proptype.resolve;
  1032. indextype.resolve;
  1033. readaccess.resolve;
  1034. writeaccess.resolve;
  1035. storedaccess.resolve;
  1036. end;
  1037. end;
  1038. function tpropertysym.getsize : longint;
  1039. begin
  1040. getsize:=0;
  1041. end;
  1042. procedure tpropertysym.write(ppufile:tcompilerppufile);
  1043. begin
  1044. inherited writesym(ppufile);
  1045. ppufile.putsmallset(propoptions);
  1046. if (ppo_is_override in propoptions) then
  1047. ppufile.putderef(propoverriden)
  1048. else
  1049. begin
  1050. ppufile.puttype(proptype);
  1051. ppufile.putlongint(index);
  1052. ppufile.putlongint(default);
  1053. ppufile.puttype(indextype);
  1054. ppufile.putsymlist(readaccess);
  1055. ppufile.putsymlist(writeaccess);
  1056. ppufile.putsymlist(storedaccess);
  1057. end;
  1058. ppufile.writeentry(ibpropertysym);
  1059. end;
  1060. procedure tpropertysym.dooverride(overriden:tpropertysym);
  1061. begin
  1062. propoverriden:=overriden;
  1063. proptype:=overriden.proptype;
  1064. propoptions:=overriden.propoptions+[ppo_is_override];
  1065. index:=overriden.index;
  1066. default:=overriden.default;
  1067. indextype:=overriden.indextype;
  1068. readaccess.free;
  1069. readaccess:=overriden.readaccess.getcopy;
  1070. writeaccess.free;
  1071. writeaccess:=overriden.writeaccess.getcopy;
  1072. storedaccess.free;
  1073. storedaccess:=overriden.storedaccess.getcopy;
  1074. end;
  1075. {$ifdef GDB}
  1076. function tpropertysym.stabstring : pchar;
  1077. begin
  1078. { !!!! don't know how to handle }
  1079. stabstring:=strpnew('');
  1080. end;
  1081. procedure tpropertysym.concatstabto(asmlist : taasmoutput);
  1082. begin
  1083. { !!!! don't know how to handle }
  1084. end;
  1085. {$endif GDB}
  1086. {****************************************************************************
  1087. TFUNCRETSYM
  1088. ****************************************************************************}
  1089. constructor tfuncretsym.create(const n : string;const tt:ttype);
  1090. begin
  1091. inherited create(n);
  1092. typ:=funcretsym;
  1093. returntype:=tt;
  1094. funcretstate:=vs_declared;
  1095. { address valid for ret in param only }
  1096. { otherwise set by insert }
  1097. address:=pprocinfo(procinfo)^.return_offset;
  1098. end;
  1099. constructor tfuncretsym.load(ppufile:tcompilerppufile);
  1100. begin
  1101. inherited loadsym(ppufile);
  1102. ppufile.gettype(returntype);
  1103. address:=ppufile.getlongint;
  1104. typ:=funcretsym;
  1105. end;
  1106. destructor tfuncretsym.destroy;
  1107. begin
  1108. inherited destroy;
  1109. end;
  1110. procedure tfuncretsym.write(ppufile:tcompilerppufile);
  1111. begin
  1112. inherited writesym(ppufile);
  1113. ppufile.puttype(returntype);
  1114. ppufile.putlongint(address);
  1115. ppufile.writeentry(ibfuncretsym);
  1116. funcretstate:=vs_used;
  1117. end;
  1118. procedure tfuncretsym.deref;
  1119. begin
  1120. returntype.resolve;
  1121. end;
  1122. {$ifdef GDB}
  1123. procedure tfuncretsym.concatstabto(asmlist : taasmoutput);
  1124. begin
  1125. { Nothing to do here, it is done in genexitcode }
  1126. end;
  1127. {$endif GDB}
  1128. procedure tfuncretsym.insert_in_data;
  1129. var
  1130. varalign,l : longint;
  1131. begin
  1132. { if retoffset is already set then reuse it, this is needed
  1133. when inserting the result variable }
  1134. if procinfo^.return_offset<>0 then
  1135. address:=procinfo^.return_offset
  1136. else
  1137. begin
  1138. { allocate space in local if ret in acc or in fpu }
  1139. if paramanager.ret_in_acc(returntype.def) or
  1140. (returntype.def.deftype=floatdef) then
  1141. begin
  1142. l:=returntype.def.size;
  1143. varalign:=size_2_align(l);
  1144. varalign:=used_align(varalign,aktalignment.localalignmin,owner.dataalignment);
  1145. address:=align(owner.datasize+l,varalign);
  1146. owner.datasize:=address;
  1147. procinfo^.return_offset:=-address;
  1148. end;
  1149. end;
  1150. end;
  1151. {****************************************************************************
  1152. TABSOLUTESYM
  1153. ****************************************************************************}
  1154. constructor tabsolutesym.create(const n : string;const tt : ttype);
  1155. begin
  1156. inherited create(n,tt);
  1157. typ:=absolutesym;
  1158. end;
  1159. constructor tabsolutesym.load(ppufile:tcompilerppufile);
  1160. begin
  1161. { Note: This needs to load everything of tvarsym.write }
  1162. inherited load(ppufile);
  1163. { load absolute }
  1164. typ:=absolutesym;
  1165. ref:=nil;
  1166. address:=0;
  1167. asmname:=nil;
  1168. abstyp:=absolutetyp(ppufile.getbyte);
  1169. absseg:=false;
  1170. case abstyp of
  1171. tovar :
  1172. asmname:=stringdup(ppufile.getstring);
  1173. toasm :
  1174. asmname:=stringdup(ppufile.getstring);
  1175. toaddr :
  1176. begin
  1177. address:=ppufile.getlongint;
  1178. absseg:=boolean(ppufile.getbyte);
  1179. end;
  1180. end;
  1181. end;
  1182. procedure tabsolutesym.write(ppufile:tcompilerppufile);
  1183. var
  1184. hvo : tvaroptions;
  1185. begin
  1186. { Note: This needs to write everything of tvarsym.write }
  1187. inherited writesym(ppufile);
  1188. ppufile.putbyte(byte(varspez));
  1189. if read_member then
  1190. ppufile.putlongint(address);
  1191. { write only definition or definitionsym }
  1192. ppufile.puttype(vartype);
  1193. hvo:=varoptions-[vo_regable];
  1194. ppufile.putsmallset(hvo);
  1195. ppufile.putbyte(byte(abstyp));
  1196. case abstyp of
  1197. tovar :
  1198. ppufile.putstring(ref.name);
  1199. toasm :
  1200. ppufile.putstring(asmname^);
  1201. toaddr :
  1202. begin
  1203. ppufile.putlongint(address);
  1204. ppufile.putbyte(byte(absseg));
  1205. end;
  1206. end;
  1207. ppufile.writeentry(ibabsolutesym);
  1208. end;
  1209. procedure tabsolutesym.deref;
  1210. var
  1211. srsym : tsym;
  1212. srsymtable : tsymtable;
  1213. begin
  1214. { inheritance of varsym.deref ! }
  1215. vartype.resolve;
  1216. { own absolute deref }
  1217. if (abstyp=tovar) and (asmname<>nil) then
  1218. begin
  1219. { search previous loaded symtables }
  1220. searchsym(asmname^,srsym,srsymtable);
  1221. if not assigned(srsym) then
  1222. srsym:=searchsymonlyin(owner,asmname^);
  1223. if not assigned(srsym) then
  1224. srsym:=generrorsym;
  1225. ref:=tstoredsym(srsym);
  1226. stringdispose(asmname);
  1227. end;
  1228. end;
  1229. function tabsolutesym.mangledname : string;
  1230. begin
  1231. case abstyp of
  1232. tovar :
  1233. begin
  1234. case ref.typ of
  1235. varsym :
  1236. mangledname:=tvarsym(ref).mangledname;
  1237. else
  1238. internalerror(200111011);
  1239. end;
  1240. end;
  1241. toasm :
  1242. mangledname:=asmname^;
  1243. toaddr :
  1244. mangledname:='$'+tostr(address);
  1245. else
  1246. internalerror(10002);
  1247. end;
  1248. end;
  1249. procedure tabsolutesym.insert_in_data;
  1250. begin
  1251. end;
  1252. {$ifdef GDB}
  1253. procedure tabsolutesym.concatstabto(asmlist : taasmoutput);
  1254. begin
  1255. { I don't know how to handle this !! }
  1256. end;
  1257. {$endif GDB}
  1258. {****************************************************************************
  1259. TVARSYM
  1260. ****************************************************************************}
  1261. constructor tvarsym.create(const n : string;const tt : ttype);
  1262. begin
  1263. inherited create(n);
  1264. typ:=varsym;
  1265. vartype:=tt;
  1266. _mangledname:=nil;
  1267. varspez:=vs_value;
  1268. address:=0;
  1269. localvarsym:=nil;
  1270. refs:=0;
  1271. varstate:=vs_used;
  1272. varoptions:=[];
  1273. { can we load the value into a register ? }
  1274. if tstoreddef(tt.def).is_intregable then
  1275. include(varoptions,vo_regable)
  1276. else
  1277. exclude(varoptions,vo_regable);
  1278. if tstoreddef(tt.def).is_fpuregable then
  1279. include(varoptions,vo_fpuregable)
  1280. else
  1281. exclude(varoptions,vo_fpuregable);
  1282. reg:=R_NO;
  1283. end;
  1284. constructor tvarsym.create_dll(const n : string;const tt : ttype);
  1285. begin
  1286. tvarsym(self).create(n,tt);
  1287. include(varoptions,vo_is_dll_var);
  1288. end;
  1289. constructor tvarsym.create_C(const n,mangled : string;const tt : ttype);
  1290. begin
  1291. tvarsym(self).create(n,tt);
  1292. include(varoptions,vo_is_C_var);
  1293. stringdispose(_mangledname);
  1294. _mangledname:=stringdup(mangled);
  1295. end;
  1296. constructor tvarsym.load(ppufile:tcompilerppufile);
  1297. begin
  1298. inherited loadsym(ppufile);
  1299. typ:=varsym;
  1300. reg:=R_NO;
  1301. refs := 0;
  1302. varstate:=vs_used;
  1303. varspez:=tvarspez(ppufile.getbyte);
  1304. if read_member then
  1305. address:=ppufile.getlongint
  1306. else
  1307. address:=0;
  1308. localvarsym:=nil;
  1309. ppufile.gettype(vartype);
  1310. ppufile.getsmallset(varoptions);
  1311. if (vo_is_C_var in varoptions) then
  1312. _mangledname:=stringdup(ppufile.getstring);
  1313. end;
  1314. destructor tvarsym.destroy;
  1315. begin
  1316. inherited destroy;
  1317. end;
  1318. procedure tvarsym.deref;
  1319. begin
  1320. vartype.resolve;
  1321. end;
  1322. procedure tvarsym.write(ppufile:tcompilerppufile);
  1323. var
  1324. hvo : tvaroptions;
  1325. begin
  1326. inherited writesym(ppufile);
  1327. ppufile.putbyte(byte(varspez));
  1328. if read_member then
  1329. ppufile.putlongint(address);
  1330. ppufile.puttype(vartype);
  1331. { symbols which are load are never candidates for a register,
  1332. turn off the regable }
  1333. hvo:=varoptions-[vo_regable,vo_fpuregable];
  1334. ppufile.putsmallset(hvo);
  1335. if (vo_is_C_var in varoptions) then
  1336. ppufile.putstring(mangledname);
  1337. ppufile.writeentry(ibvarsym);
  1338. end;
  1339. procedure tvarsym.generate_mangledname;
  1340. begin
  1341. _mangledname:=stringdup(mangledname_prefix('U',owner)+name);
  1342. end;
  1343. procedure tvarsym.set_mangledname(const s:string);
  1344. begin
  1345. stringdispose(_mangledname);
  1346. _mangledname:=stringdup(s);
  1347. end;
  1348. function tvarsym.getsize : longint;
  1349. begin
  1350. if assigned(vartype.def) then
  1351. getsize:=vartype.def.size
  1352. else
  1353. getsize:=0;
  1354. end;
  1355. function tvarsym.getvaluesize : longint;
  1356. begin
  1357. if assigned(vartype.def) and
  1358. (varspez=vs_value) and
  1359. ((vartype.def.deftype<>arraydef) or
  1360. tarraydef(vartype.def).isDynamicArray or
  1361. (tarraydef(vartype.def).highrange>=tarraydef(vartype.def).lowrange)) then
  1362. getvaluesize:=vartype.def.size
  1363. else
  1364. getvaluesize:=0;
  1365. end;
  1366. function tvarsym.getpushsize : longint;
  1367. begin
  1368. if assigned(vartype.def) then
  1369. begin
  1370. case varspez of
  1371. vs_out,
  1372. vs_var :
  1373. getpushsize:=pointer_size;
  1374. vs_value,
  1375. vs_const :
  1376. begin
  1377. if paramanager.push_addr_param(vartype.def) then
  1378. getpushsize:=pointer_size
  1379. else
  1380. getpushsize:=vartype.def.size;
  1381. end;
  1382. end;
  1383. end
  1384. else
  1385. getpushsize:=0;
  1386. end;
  1387. procedure tvarsym.insert_in_data;
  1388. var
  1389. varalign,
  1390. l,modulo : longint;
  1391. storefilepos : tfileposinfo;
  1392. begin
  1393. if (vo_is_external in varoptions) then
  1394. exit;
  1395. { handle static variables of objects especially }
  1396. if read_member and (owner.symtabletype=objectsymtable) and
  1397. (sp_static in symoptions) then
  1398. begin
  1399. { the data filed is generated in parser.pas
  1400. with a tobject_FIELDNAME variable }
  1401. { this symbol can't be loaded to a register }
  1402. exclude(varoptions,vo_regable);
  1403. exclude(varoptions,vo_fpuregable);
  1404. end
  1405. else
  1406. if not(read_member) then
  1407. begin
  1408. { made problems with parameters etc. ! (FK) }
  1409. { check for instance of an abstract object or class }
  1410. {
  1411. if (tvarsym(sym).definition.deftype=objectdef) and
  1412. ((tobjectdef(tvarsym(sym).definition).options and oo_is_abstract)<>0) then
  1413. Message(sym_e_no_instance_of_abstract_object);
  1414. }
  1415. storefilepos:=aktfilepos;
  1416. aktfilepos:=akttokenpos;
  1417. if (vo_is_thread_var in varoptions) then
  1418. l:=pointer_size
  1419. else
  1420. l:=getvaluesize;
  1421. case owner.symtabletype of
  1422. stt_exceptsymtable:
  1423. { can contain only one symbol, address calculated later }
  1424. ;
  1425. localsymtable :
  1426. begin
  1427. varstate:=vs_declared;
  1428. varalign:=size_2_align(l);
  1429. varalign:=used_align(varalign,aktalignment.localalignmin,aktalignment.localalignmax);
  1430. address:=align(owner.datasize+l,varalign);
  1431. owner.datasize:=address;
  1432. end;
  1433. staticsymtable :
  1434. begin
  1435. { enable unitialized warning for local symbols }
  1436. varstate:=vs_declared;
  1437. varalign:=size_2_align(l);
  1438. varalign:=used_align(varalign,aktalignment.varalignmin,aktalignment.varalignmax);
  1439. address:=align(owner.datasize,varalign);
  1440. { insert cut for smartlinking or alignment }
  1441. if (cs_create_smart in aktmoduleswitches) then
  1442. bssSegment.concat(Tai_cut.Create)
  1443. else if (address<>owner.datasize) then
  1444. bssSegment.concat(Tai_align.create(varalign));
  1445. owner.datasize:=address+l;
  1446. {$ifdef GDB}
  1447. if cs_debuginfo in aktmoduleswitches then
  1448. concatstabto(bsssegment);
  1449. {$endif GDB}
  1450. if (cs_create_smart in aktmoduleswitches) or
  1451. DLLSource or
  1452. (vo_is_exported in varoptions) or
  1453. (vo_is_C_var in varoptions) then
  1454. bssSegment.concat(Tai_datablock.Create_global(mangledname,l))
  1455. else
  1456. bssSegment.concat(Tai_datablock.Create(mangledname,l));
  1457. {Global variables (in implementation part of course)
  1458. *can* be loaded into registers, they just may not be
  1459. accessed from procedures. The lexlevel test in nld.pas,
  1460. Tloadnode.pass_1, should take care of this.
  1461. If for some reason you think it isn't safe, try isolating
  1462. and disabling those specific cases, because small programs
  1463. without procedures can be very speed critical. For example,
  1464. think of benchmarks and programming contests. Also, new
  1465. users often test the quality of the code the compiler
  1466. generates and they do that with small programs, we should
  1467. show them the full optimizing power. (DM)}
  1468. {exclude(varoptions,vo_regable);
  1469. exclude(varoptions,vo_fpuregable);}
  1470. end;
  1471. globalsymtable :
  1472. begin
  1473. varalign:=size_2_align(l);
  1474. varalign:=used_align(varalign,aktalignment.varalignmin,aktalignment.varalignmax);
  1475. address:=align(owner.datasize,varalign);
  1476. { insert cut for smartlinking or alignment }
  1477. if (cs_create_smart in aktmoduleswitches) then
  1478. bssSegment.concat(Tai_cut.Create)
  1479. else if (address<>owner.datasize) then
  1480. bssSegment.concat(Tai_align.create(varalign));
  1481. owner.datasize:=address+l;
  1482. {$ifdef GDB}
  1483. if cs_debuginfo in aktmoduleswitches then
  1484. concatstabto(bsssegment);
  1485. {$endif GDB}
  1486. bssSegment.concat(Tai_datablock.Create_global(mangledname,l));
  1487. { this symbol can't be loaded to a register }
  1488. exclude(varoptions,vo_regable);
  1489. exclude(varoptions,vo_fpuregable);
  1490. end;
  1491. recordsymtable,
  1492. objectsymtable :
  1493. begin
  1494. { this symbol can't be loaded to a register }
  1495. exclude(varoptions,vo_regable);
  1496. exclude(varoptions,vo_fpuregable);
  1497. { get the alignment size }
  1498. if (aktalignment.recordalignmax=-1) then
  1499. begin
  1500. varalign:=vartype.def.alignment;
  1501. if (varalign>4) and ((varalign mod 4)<>0) and
  1502. (vartype.def.deftype=arraydef) then
  1503. begin
  1504. Message1(sym_w_wrong_C_pack,vartype.def.typename);
  1505. end;
  1506. if varalign=0 then
  1507. varalign:=l;
  1508. if (owner.dataalignment<aktalignment.maxCrecordalign) then
  1509. begin
  1510. if (varalign>16) and (owner.dataalignment<32) then
  1511. owner.dataalignment:=32
  1512. else if (varalign>12) and (owner.dataalignment<16) then
  1513. owner.dataalignment:=16
  1514. { 12 is needed for long double }
  1515. else if (varalign>8) and (owner.dataalignment<12) then
  1516. owner.dataalignment:=12
  1517. else if (varalign>4) and (owner.dataalignment<8) then
  1518. owner.dataalignment:=8
  1519. else if (varalign>2) and (owner.dataalignment<4) then
  1520. owner.dataalignment:=4
  1521. else if (varalign>1) and (owner.dataalignment<2) then
  1522. owner.dataalignment:=2;
  1523. end;
  1524. owner.dataalignment:=max(owner.dataalignment,aktalignment.maxCrecordalign);
  1525. end
  1526. else
  1527. varalign:=vartype.def.alignment;
  1528. if varalign=0 then
  1529. varalign:=size_2_align(l);
  1530. varalign:=used_align(varalign,aktalignment.recordalignmin,owner.dataalignment);
  1531. address:=align(owner.datasize,varalign);
  1532. owner.datasize:=address+l;
  1533. end;
  1534. parasymtable :
  1535. begin
  1536. { here we need the size of a push instead of the
  1537. size of the data }
  1538. l:=getpushsize;
  1539. varalign:=size_2_align(l);
  1540. varstate:=vs_assigned;
  1541. { we need the new datasize already aligned so we can't
  1542. use the align_address here }
  1543. address:=owner.datasize;
  1544. varalign:=used_align(varalign,owner.dataalignment,owner.dataalignment);
  1545. owner.datasize:=align(address+l,varalign);
  1546. end
  1547. else
  1548. begin
  1549. modulo:=owner.datasize and 3;
  1550. if (l>=4) and (modulo<>0) then
  1551. inc(owner.datasize,4-modulo)
  1552. else
  1553. if (l>=2) and ((modulo and 1)<>0) then
  1554. inc(owner.datasize);
  1555. address:=owner.datasize;
  1556. inc(owner.datasize,l);
  1557. end;
  1558. end;
  1559. aktfilepos:=storefilepos;
  1560. end;
  1561. end;
  1562. {$ifdef GDB}
  1563. function tvarsym.stabstring : pchar;
  1564. var
  1565. st : string;
  1566. begin
  1567. st:=tstoreddef(vartype.def).numberstring;
  1568. if (owner.symtabletype = objectsymtable) and
  1569. (sp_static in symoptions) then
  1570. begin
  1571. if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
  1572. stabstring := strpnew('"'+upper(owner.name^)+'__'+name+':'+st+
  1573. '",'+
  1574. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1575. end
  1576. else if (owner.symtabletype = globalsymtable) then
  1577. begin
  1578. { Here we used S instead of
  1579. because with G GDB doesn't look at the address field
  1580. but searches the same name or with a leading underscore
  1581. but these names don't exist in pascal !}
  1582. if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
  1583. stabstring := strpnew('"'+name+':'+st+'",'+
  1584. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1585. end
  1586. else if owner.symtabletype = staticsymtable then
  1587. begin
  1588. stabstring := strpnew('"'+name+':S'+st+'",'+
  1589. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1590. end
  1591. else if (owner.symtabletype in [parasymtable,inlineparasymtable]) then
  1592. begin
  1593. case varspez of
  1594. vs_out,
  1595. vs_var : st := 'v'+st;
  1596. vs_value,
  1597. vs_const : if paramanager.push_addr_param(vartype.def) then
  1598. st := 'v'+st { should be 'i' but 'i' doesn't work }
  1599. else
  1600. st := 'p'+st;
  1601. end;
  1602. stabstring := strpnew('"'+name+':'+st+'",'+
  1603. tostr(N_tsym)+',0,'+tostr(fileinfo.line)+','+
  1604. tostr(address+owner.address_fixup));
  1605. {offset to ebp => will not work if the framepointer is esp
  1606. so some optimizing will make things harder to debug }
  1607. end
  1608. else if (owner.symtabletype in [localsymtable,inlinelocalsymtable]) then
  1609. {$ifdef i386}
  1610. if reg<>R_NO then
  1611. begin
  1612. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1613. { this is the register order for GDB}
  1614. stabstring:=strpnew('"'+name+':r'+st+'",'+
  1615. tostr(N_RSYM)+',0,'+
  1616. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1617. end
  1618. else
  1619. {$endif i386}
  1620. { I don't know if this will work (PM) }
  1621. if (vo_is_C_var in varoptions) then
  1622. stabstring := strpnew('"'+name+':S'+st+'",'+
  1623. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname)
  1624. else
  1625. stabstring := strpnew('"'+name+':'+st+'",'+
  1626. tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address-owner.address_fixup))
  1627. else
  1628. stabstring := inherited stabstring;
  1629. end;
  1630. procedure tvarsym.concatstabto(asmlist : taasmoutput);
  1631. {$ifdef i386}
  1632. var stab_str : pchar;
  1633. {$endif i386}
  1634. begin
  1635. inherited concatstabto(asmlist);
  1636. {$ifdef i386}
  1637. if (owner.symtabletype=parasymtable) and
  1638. (reg<>R_NO) then
  1639. begin
  1640. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1641. { this is the register order for GDB}
  1642. stab_str:=strpnew('"'+name+':r'
  1643. +tstoreddef(vartype.def).numberstring+'",'+
  1644. tostr(N_RSYM)+',0,'+
  1645. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1646. asmList.concat(Tai_stabs.Create(stab_str));
  1647. end;
  1648. {$endif i386}
  1649. end;
  1650. {$endif GDB}
  1651. {****************************************************************************
  1652. TTYPEDCONSTSYM
  1653. *****************************************************************************}
  1654. constructor ttypedconstsym.create(const n : string;p : tdef;writable : boolean);
  1655. begin
  1656. inherited create(n);
  1657. typ:=typedconstsym;
  1658. typedconsttype.setdef(p);
  1659. is_writable:=writable;
  1660. end;
  1661. constructor ttypedconstsym.createtype(const n : string;const tt : ttype;writable : boolean);
  1662. begin
  1663. inherited create(n);
  1664. typ:=typedconstsym;
  1665. typedconsttype:=tt;
  1666. is_writable:=writable;
  1667. end;
  1668. constructor ttypedconstsym.load(ppufile:tcompilerppufile);
  1669. begin
  1670. inherited loadsym(ppufile);
  1671. typ:=typedconstsym;
  1672. ppufile.gettype(typedconsttype);
  1673. is_writable:=boolean(ppufile.getbyte);
  1674. end;
  1675. destructor ttypedconstsym.destroy;
  1676. begin
  1677. inherited destroy;
  1678. end;
  1679. procedure ttypedconstsym.generate_mangledname;
  1680. begin
  1681. _mangledname:=stringdup(mangledname_prefix('TC',owner)+name);
  1682. end;
  1683. function ttypedconstsym.getsize : longint;
  1684. begin
  1685. if assigned(typedconsttype.def) then
  1686. getsize:=typedconsttype.def.size
  1687. else
  1688. getsize:=0;
  1689. end;
  1690. procedure ttypedconstsym.deref;
  1691. begin
  1692. typedconsttype.resolve;
  1693. end;
  1694. procedure ttypedconstsym.write(ppufile:tcompilerppufile);
  1695. begin
  1696. inherited writesym(ppufile);
  1697. ppufile.puttype(typedconsttype);
  1698. ppufile.putbyte(byte(is_writable));
  1699. ppufile.writeentry(ibtypedconstsym);
  1700. end;
  1701. procedure ttypedconstsym.insert_in_data;
  1702. var
  1703. curconstsegment : taasmoutput;
  1704. address,l,varalign : longint;
  1705. storefilepos : tfileposinfo;
  1706. begin
  1707. storefilepos:=aktfilepos;
  1708. aktfilepos:=akttokenpos;
  1709. if is_writable then
  1710. curconstsegment:=datasegment
  1711. else
  1712. curconstsegment:=consts;
  1713. l:=getsize;
  1714. varalign:=size_2_align(l);
  1715. varalign:=used_align(varalign,aktalignment.constalignmin,aktalignment.constalignmax);
  1716. address:=align(owner.datasize,varalign);
  1717. { insert cut for smartlinking or alignment }
  1718. if (cs_create_smart in aktmoduleswitches) then
  1719. curconstSegment.concat(Tai_cut.Create)
  1720. else if (address<>owner.datasize) then
  1721. curconstSegment.concat(Tai_align.create(varalign));
  1722. owner.datasize:=address+l;
  1723. {$ifdef GDB}
  1724. if cs_debuginfo in aktmoduleswitches then
  1725. concatstabto(curconstsegment);
  1726. {$endif GDB}
  1727. if (owner.symtabletype=globalsymtable) then
  1728. begin
  1729. if (owner.unitid=0) then
  1730. curconstSegment.concat(Tai_symbol.Createdataname_global(mangledname,getsize));
  1731. end
  1732. else
  1733. begin
  1734. if (cs_create_smart in aktmoduleswitches) or
  1735. DLLSource then
  1736. curconstSegment.concat(Tai_symbol.Createdataname_global(mangledname,getsize))
  1737. else
  1738. curconstSegment.concat(Tai_symbol.Createdataname(mangledname,getsize));
  1739. end;
  1740. aktfilepos:=storefilepos;
  1741. end;
  1742. {$ifdef GDB}
  1743. function ttypedconstsym.stabstring : pchar;
  1744. var
  1745. st : char;
  1746. begin
  1747. if (cs_gdb_gsym in aktglobalswitches) and (owner.symtabletype=globalsymtable) then
  1748. st := 'G'
  1749. else
  1750. st := 'S';
  1751. stabstring := strpnew('"'+name+':'+st+
  1752. tstoreddef(typedconsttype.def).numberstring+'",'+tostr(n_STSYM)+',0,'+
  1753. tostr(fileinfo.line)+','+mangledname);
  1754. end;
  1755. {$endif GDB}
  1756. {****************************************************************************
  1757. TCONSTSYM
  1758. ****************************************************************************}
  1759. constructor tconstsym.create_ord(const n : string;t : tconsttyp;v : TConstExprInt);
  1760. begin
  1761. inherited create(n);
  1762. typ:=constsym;
  1763. consttyp:=t;
  1764. valueord:=v;
  1765. valueordptr:=0;
  1766. valueptr:=nil;
  1767. ResStrIndex:=0;
  1768. consttype.reset;
  1769. len:=0;
  1770. end;
  1771. constructor tconstsym.create_ord_typed(const n : string;t : tconsttyp;v : tconstexprint;const tt:ttype);
  1772. begin
  1773. inherited create(n);
  1774. typ:=constsym;
  1775. consttyp:=t;
  1776. valueord:=v;
  1777. valueordptr:=0;
  1778. valueptr:=nil;
  1779. ResStrIndex:=0;
  1780. consttype:=tt;
  1781. len:=0;
  1782. end;
  1783. constructor tconstsym.create_ordptr_typed(const n : string;t : tconsttyp;v : tconstptruint;const tt:ttype);
  1784. begin
  1785. inherited create(n);
  1786. typ:=constsym;
  1787. consttyp:=t;
  1788. valueord:=0;
  1789. valueordptr:=v;
  1790. valueptr:=nil;
  1791. ResStrIndex:=0;
  1792. consttype:=tt;
  1793. len:=0;
  1794. end;
  1795. constructor tconstsym.create_ptr(const n : string;t : tconsttyp;v : pointer);
  1796. begin
  1797. inherited create(n);
  1798. typ:=constsym;
  1799. consttyp:=t;
  1800. valueord:=0;
  1801. valueordptr:=0;
  1802. valueptr:=v;
  1803. ResStrIndex:=0;
  1804. consttype.reset;
  1805. len:=0;
  1806. end;
  1807. constructor tconstsym.create_ptr_typed(const n : string;t : tconsttyp;v : pointer;const tt:ttype);
  1808. begin
  1809. inherited create(n);
  1810. typ:=constsym;
  1811. consttyp:=t;
  1812. valueord:=0;
  1813. valueordptr:=0;
  1814. valueptr:=v;
  1815. ResStrIndex:=0;
  1816. consttype:=tt;
  1817. len:=0;
  1818. end;
  1819. constructor tconstsym.create_string(const n : string;t : tconsttyp;str:pchar;l:longint);
  1820. begin
  1821. inherited create(n);
  1822. typ:=constsym;
  1823. consttyp:=t;
  1824. valueord:=0;
  1825. valueordptr:=0;
  1826. valueptr:=str;
  1827. consttype.reset;
  1828. len:=l;
  1829. if t=constresourcestring then
  1830. ResStrIndex:=ResourceStrings.Register(name,pchar(valueptr),len);
  1831. end;
  1832. constructor tconstsym.load(ppufile:tcompilerppufile);
  1833. var
  1834. pd : pbestreal;
  1835. ps : pnormalset;
  1836. pc : pchar;
  1837. l1,l2 : longint;
  1838. begin
  1839. inherited loadsym(ppufile);
  1840. typ:=constsym;
  1841. consttype.reset;
  1842. consttyp:=tconsttyp(ppufile.getbyte);
  1843. valueord:=0;
  1844. valueordptr:=0;
  1845. valueptr:=nil;
  1846. case consttyp of
  1847. constint:
  1848. if sizeof(tconstexprint)=8 then
  1849. begin
  1850. l1:=ppufile.getlongint;
  1851. l2:=ppufile.getlongint;
  1852. {$ifopt R+}
  1853. {$define Range_check_on}
  1854. {$endif opt R+}
  1855. {$R- needed here }
  1856. valueord:=qword(l1)+(int64(l2) shl 32);
  1857. {$ifdef Range_check_on}
  1858. {$R+}
  1859. {$undef Range_check_on}
  1860. {$endif Range_check_on}
  1861. end
  1862. else
  1863. valueord:=ppufile.getlongint;
  1864. constwchar,
  1865. constbool,
  1866. constchar :
  1867. valueord:=ppufile.getlongint;
  1868. constord :
  1869. begin
  1870. ppufile.gettype(consttype);
  1871. if sizeof(TConstExprInt)=8 then
  1872. begin
  1873. l1:=ppufile.getlongint;
  1874. l2:=ppufile.getlongint;
  1875. {$ifopt R+}
  1876. {$define Range_check_on}
  1877. {$endif opt R+}
  1878. {$R- needed here }
  1879. valueord:=qword(l1)+(int64(l2) shl 32);
  1880. {$ifdef Range_check_on}
  1881. {$R+}
  1882. {$undef Range_check_on}
  1883. {$endif Range_check_on}
  1884. end
  1885. else
  1886. valueord:=ppufile.getlongint;
  1887. end;
  1888. constpointer :
  1889. begin
  1890. ppufile.gettype(consttype);
  1891. if sizeof(TConstPtrUInt)=8 then
  1892. begin
  1893. l1:=ppufile.getlongint;
  1894. l2:=ppufile.getlongint;
  1895. {$ifopt R+}
  1896. {$define Range_check_on}
  1897. {$endif opt R+}
  1898. {$R- needed here }
  1899. valueordptr:=qword(l1)+(int64(l2) shl 32);
  1900. {$ifdef Range_check_on}
  1901. {$R+}
  1902. {$undef Range_check_on}
  1903. {$endif Range_check_on}
  1904. end
  1905. else
  1906. valueordptr:=cardinal(ppufile.getlongint);
  1907. end;
  1908. conststring,
  1909. constresourcestring :
  1910. begin
  1911. len:=ppufile.getlongint;
  1912. getmem(pc,len+1);
  1913. ppufile.getdata(pc^,len);
  1914. if consttyp=constresourcestring then
  1915. ResStrIndex:=ppufile.getlongint;
  1916. valueptr:=pc;
  1917. end;
  1918. constreal :
  1919. begin
  1920. new(pd);
  1921. pd^:=ppufile.getreal;
  1922. valueptr:=pd;
  1923. end;
  1924. constset :
  1925. begin
  1926. ppufile.gettype(consttype);
  1927. new(ps);
  1928. ppufile.getnormalset(ps^);
  1929. valueptr:=ps;
  1930. end;
  1931. constnil : ;
  1932. else
  1933. Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp)));
  1934. end;
  1935. end;
  1936. destructor tconstsym.destroy;
  1937. begin
  1938. case consttyp of
  1939. conststring,
  1940. constresourcestring :
  1941. freemem(pchar(valueptr),len+1);
  1942. constreal :
  1943. dispose(pbestreal(valueptr));
  1944. constset :
  1945. dispose(pnormalset(valueptr));
  1946. end;
  1947. inherited destroy;
  1948. end;
  1949. function tconstsym.mangledname : string;
  1950. begin
  1951. mangledname:=name;
  1952. end;
  1953. procedure tconstsym.deref;
  1954. begin
  1955. if consttyp in [constord,constpointer,constset] then
  1956. consttype.resolve;
  1957. end;
  1958. procedure tconstsym.write(ppufile:tcompilerppufile);
  1959. begin
  1960. inherited writesym(ppufile);
  1961. ppufile.putbyte(byte(consttyp));
  1962. case consttyp of
  1963. constnil : ;
  1964. constint:
  1965. begin
  1966. if sizeof(TConstExprInt)=8 then
  1967. begin
  1968. ppufile.putlongint(longint(lo(valueord)));
  1969. ppufile.putlongint(longint(hi(valueord)));
  1970. end
  1971. else
  1972. ppufile.putlongint(valueord);
  1973. end;
  1974. constbool,
  1975. constchar :
  1976. ppufile.putlongint(valueord);
  1977. constord :
  1978. begin
  1979. ppufile.puttype(consttype);
  1980. if sizeof(TConstExprInt)=8 then
  1981. begin
  1982. ppufile.putlongint(longint(lo(valueord)));
  1983. ppufile.putlongint(longint(hi(valueord)));
  1984. end
  1985. else
  1986. ppufile.putlongint(valueord);
  1987. end;
  1988. constpointer :
  1989. begin
  1990. ppufile.puttype(consttype);
  1991. if sizeof(TConstPtrUInt)=8 then
  1992. begin
  1993. ppufile.putlongint(longint(lo(valueordptr)));
  1994. ppufile.putlongint(longint(hi(valueordptr)));
  1995. end
  1996. else
  1997. ppufile.putlongint(longint(valueordptr));
  1998. end;
  1999. conststring,
  2000. constresourcestring :
  2001. begin
  2002. ppufile.putlongint(len);
  2003. ppufile.putdata(pchar(valueptr)^,len);
  2004. if consttyp=constresourcestring then
  2005. ppufile.putlongint(ResStrIndex);
  2006. end;
  2007. constreal :
  2008. ppufile.putreal(pbestreal(valueptr)^);
  2009. constset :
  2010. begin
  2011. ppufile.puttype(consttype);
  2012. ppufile.putnormalset(valueptr^);
  2013. end;
  2014. else
  2015. internalerror(13);
  2016. end;
  2017. ppufile.writeentry(ibconstsym);
  2018. end;
  2019. {$ifdef GDB}
  2020. function tconstsym.stabstring : pchar;
  2021. var st : string;
  2022. begin
  2023. {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
  2024. case consttyp of
  2025. conststring : begin
  2026. st := 's'''+strpas(pchar(valueptr))+'''';
  2027. end;
  2028. constbool,
  2029. constint,
  2030. constord,
  2031. constchar : st := 'i'+int64tostr(valueord);
  2032. constpointer :
  2033. st := 'i'+int64tostr(valueordptr);
  2034. constreal : begin
  2035. system.str(pbestreal(valueptr)^,st);
  2036. st := 'r'+st;
  2037. end;
  2038. { if we don't know just put zero !! }
  2039. else st:='i0';
  2040. {***SETCONST}
  2041. {constset:;} {*** I don't know what to do with a set.}
  2042. { sets are not recognized by GDB}
  2043. {***}
  2044. end;
  2045. stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
  2046. tostr(fileinfo.line)+',0');
  2047. end;
  2048. procedure tconstsym.concatstabto(asmlist : taasmoutput);
  2049. begin
  2050. if consttyp <> conststring then
  2051. inherited concatstabto(asmlist);
  2052. end;
  2053. {$endif GDB}
  2054. {****************************************************************************
  2055. TENUMSYM
  2056. ****************************************************************************}
  2057. constructor tenumsym.create(const n : string;def : tenumdef;v : longint);
  2058. begin
  2059. inherited create(n);
  2060. typ:=enumsym;
  2061. definition:=def;
  2062. value:=v;
  2063. { check for jumps }
  2064. if v>def.max+1 then
  2065. def.has_jumps:=true;
  2066. { update low and high }
  2067. if def.min>v then
  2068. def.setmin(v);
  2069. if def.max<v then
  2070. def.setmax(v);
  2071. order;
  2072. end;
  2073. constructor tenumsym.load(ppufile:tcompilerppufile);
  2074. begin
  2075. inherited loadsym(ppufile);
  2076. typ:=enumsym;
  2077. definition:=tenumdef(ppufile.getderef);
  2078. value:=ppufile.getlongint;
  2079. nextenum := Nil;
  2080. end;
  2081. procedure tenumsym.deref;
  2082. begin
  2083. resolvedef(pointer(definition));
  2084. order;
  2085. end;
  2086. procedure tenumsym.order;
  2087. var
  2088. sym : tenumsym;
  2089. begin
  2090. sym := tenumsym(definition.firstenum);
  2091. if sym = nil then
  2092. begin
  2093. definition.firstenum := self;
  2094. nextenum := nil;
  2095. exit;
  2096. end;
  2097. { reorder the symbols in increasing value }
  2098. if value < sym.value then
  2099. begin
  2100. nextenum := sym;
  2101. definition.firstenum := self;
  2102. end
  2103. else
  2104. begin
  2105. while (sym.value <= value) and assigned(sym.nextenum) do
  2106. sym := sym.nextenum;
  2107. nextenum := sym.nextenum;
  2108. sym.nextenum := self;
  2109. end;
  2110. end;
  2111. procedure tenumsym.write(ppufile:tcompilerppufile);
  2112. begin
  2113. inherited writesym(ppufile);
  2114. ppufile.putderef(definition);
  2115. ppufile.putlongint(value);
  2116. ppufile.writeentry(ibenumsym);
  2117. end;
  2118. {$ifdef GDB}
  2119. procedure tenumsym.concatstabto(asmlist : taasmoutput);
  2120. begin
  2121. {enum elements have no stab !}
  2122. end;
  2123. {$EndIf GDB}
  2124. {****************************************************************************
  2125. TTYPESYM
  2126. ****************************************************************************}
  2127. constructor ttypesym.create(const n : string;const tt : ttype);
  2128. begin
  2129. inherited create(n);
  2130. typ:=typesym;
  2131. restype:=tt;
  2132. {$ifdef GDB}
  2133. isusedinstab := false;
  2134. {$endif GDB}
  2135. { register the typesym for the definition }
  2136. if assigned(restype.def) and
  2137. (restype.def.deftype<>errordef) and
  2138. not(assigned(restype.def.typesym)) then
  2139. restype.def.typesym:=self;
  2140. end;
  2141. constructor ttypesym.load(ppufile:tcompilerppufile);
  2142. begin
  2143. inherited loadsym(ppufile);
  2144. typ:=typesym;
  2145. {$ifdef GDB}
  2146. isusedinstab := false;
  2147. {$endif GDB}
  2148. ppufile.gettype(restype);
  2149. end;
  2150. function ttypesym.gettypedef:tdef;
  2151. begin
  2152. gettypedef:=restype.def;
  2153. end;
  2154. procedure ttypesym.deref;
  2155. begin
  2156. restype.resolve;
  2157. end;
  2158. procedure ttypesym.write(ppufile:tcompilerppufile);
  2159. begin
  2160. inherited writesym(ppufile);
  2161. ppufile.puttype(restype);
  2162. ppufile.writeentry(ibtypesym);
  2163. end;
  2164. procedure ttypesym.load_references(ppufile:tcompilerppufile;locals:boolean);
  2165. begin
  2166. inherited load_references(ppufile,locals);
  2167. if (restype.def.deftype=recorddef) then
  2168. tstoredsymtable(trecorddef(restype.def).symtable).load_references(ppufile,locals);
  2169. if (restype.def.deftype=objectdef) then
  2170. tstoredsymtable(tobjectdef(restype.def).symtable).load_references(ppufile,locals);
  2171. end;
  2172. function ttypesym.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  2173. begin
  2174. if not inherited write_references(ppufile,locals) then
  2175. begin
  2176. { write address of this symbol if record or object
  2177. even if no real refs are there
  2178. because we need it for the symtable }
  2179. if (restype.def.deftype in [recorddef,objectdef]) then
  2180. begin
  2181. ppufile.putderef(self);
  2182. ppufile.writeentry(ibsymref);
  2183. end;
  2184. end;
  2185. write_references:=true;
  2186. if (restype.def.deftype=recorddef) then
  2187. tstoredsymtable(trecorddef(restype.def).symtable).write_references(ppufile,locals);
  2188. if (restype.def.deftype=objectdef) then
  2189. tstoredsymtable(tobjectdef(restype.def).symtable).write_references(ppufile,locals);
  2190. end;
  2191. {$ifdef GDB}
  2192. function ttypesym.stabstring : pchar;
  2193. var
  2194. stabchar : string[2];
  2195. short : string;
  2196. begin
  2197. if restype.def.deftype in tagtypes then
  2198. stabchar := 'Tt'
  2199. else
  2200. stabchar := 't';
  2201. short := '"'+name+':'+stabchar+tstoreddef(restype.def).numberstring
  2202. +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
  2203. stabstring := strpnew(short);
  2204. end;
  2205. procedure ttypesym.concatstabto(asmlist : taasmoutput);
  2206. begin
  2207. {not stabs for forward defs }
  2208. if assigned(restype.def) then
  2209. if (restype.def.typesym = self) then
  2210. tstoreddef(restype.def).concatstabto(asmlist)
  2211. else
  2212. inherited concatstabto(asmlist);
  2213. end;
  2214. {$endif GDB}
  2215. {****************************************************************************
  2216. TSYSSYM
  2217. ****************************************************************************}
  2218. constructor tsyssym.create(const n : string;l : longint);
  2219. begin
  2220. inherited create(n);
  2221. typ:=syssym;
  2222. number:=l;
  2223. end;
  2224. constructor tsyssym.load(ppufile:tcompilerppufile);
  2225. begin
  2226. inherited loadsym(ppufile);
  2227. typ:=syssym;
  2228. number:=ppufile.getlongint;
  2229. end;
  2230. destructor tsyssym.destroy;
  2231. begin
  2232. inherited destroy;
  2233. end;
  2234. procedure tsyssym.write(ppufile:tcompilerppufile);
  2235. begin
  2236. inherited writesym(ppufile);
  2237. ppufile.putlongint(number);
  2238. ppufile.writeentry(ibsyssym);
  2239. end;
  2240. {$ifdef GDB}
  2241. procedure tsyssym.concatstabto(asmlist : taasmoutput);
  2242. begin
  2243. end;
  2244. {$endif GDB}
  2245. {****************************************************************************
  2246. TRTTISYM
  2247. ****************************************************************************}
  2248. constructor trttisym.create(const n:string;rt:trttitype);
  2249. const
  2250. prefix : array[trttitype] of string[5]=('$rtti','$init');
  2251. begin
  2252. inherited create(prefix[rt]+n);
  2253. typ:=rttisym;
  2254. lab:=nil;
  2255. rttityp:=rt;
  2256. end;
  2257. constructor trttisym.load(ppufile:tcompilerppufile);
  2258. begin
  2259. inherited loadsym(ppufile);
  2260. typ:=rttisym;
  2261. lab:=nil;
  2262. rttityp:=trttitype(ppufile.getbyte);
  2263. end;
  2264. procedure trttisym.write(ppufile:tcompilerppufile);
  2265. begin
  2266. inherited writesym(ppufile);
  2267. ppufile.putbyte(byte(rttityp));
  2268. ppufile.writeentry(ibrttisym);
  2269. end;
  2270. function trttisym.mangledname : string;
  2271. const
  2272. prefix : array[trttitype] of string[5]=('RTTI_','INIT_');
  2273. var
  2274. s : string;
  2275. p : tsymtable;
  2276. begin
  2277. s:='';
  2278. p:=owner;
  2279. while assigned(p) and (p.symtabletype=localsymtable) do
  2280. begin
  2281. s:=s+'_'+p.defowner.name;
  2282. p:=p.defowner.owner;
  2283. end;
  2284. if not(p.symtabletype in [globalsymtable,staticsymtable]) then
  2285. internalerror(200108265);
  2286. mangledname:=prefix[rttityp]+p.name^+s+'$_'+Copy(name,5,255);
  2287. end;
  2288. function trttisym.get_label:tasmsymbol;
  2289. begin
  2290. { the label is always a global label }
  2291. if not assigned(lab) then
  2292. lab:=newasmsymboltype(mangledname,AB_GLOBAL,AT_DATA);
  2293. get_label:=lab;
  2294. end;
  2295. { persistent rtti generation }
  2296. procedure generate_rtti(p:tsym);
  2297. var
  2298. rsym : trttisym;
  2299. def : tstoreddef;
  2300. begin
  2301. { rtti can only be generated for classes that are always typesyms }
  2302. if not(p.typ=typesym) then
  2303. internalerror(200108261);
  2304. def:=tstoreddef(ttypesym(p).restype.def);
  2305. { only create rtti once for each definition }
  2306. if not(df_has_rttitable in def.defoptions) then
  2307. begin
  2308. { definition should be in the same symtable as the symbol }
  2309. if p.owner<>def.owner then
  2310. internalerror(200108262);
  2311. { create rttisym }
  2312. rsym:=trttisym.create(p.name,fullrtti);
  2313. p.owner.insert(rsym);
  2314. { register rttisym in definition }
  2315. include(def.defoptions,df_has_rttitable);
  2316. def.rttitablesym:=rsym;
  2317. { write rtti data }
  2318. def.write_child_rtti_data(fullrtti);
  2319. if (cs_create_smart in aktmoduleswitches) then
  2320. rttiList.concat(Tai_cut.Create);
  2321. rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
  2322. def.write_rtti_data(fullrtti);
  2323. rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
  2324. end;
  2325. end;
  2326. { persistent init table generation }
  2327. procedure generate_inittable(p:tsym);
  2328. var
  2329. rsym : trttisym;
  2330. def : tstoreddef;
  2331. begin
  2332. { anonymous types are also allowed for records that can be varsym }
  2333. case p.typ of
  2334. typesym :
  2335. def:=tstoreddef(ttypesym(p).restype.def);
  2336. varsym :
  2337. def:=tstoreddef(tvarsym(p).vartype.def);
  2338. else
  2339. internalerror(200108263);
  2340. end;
  2341. { only create inittable once for each definition }
  2342. if not(df_has_inittable in def.defoptions) then
  2343. begin
  2344. { definition should be in the same symtable as the symbol }
  2345. if p.owner<>def.owner then
  2346. internalerror(200108264);
  2347. { create rttisym }
  2348. rsym:=trttisym.create(p.name,initrtti);
  2349. p.owner.insert(rsym);
  2350. { register rttisym in definition }
  2351. include(def.defoptions,df_has_inittable);
  2352. def.inittablesym:=rsym;
  2353. { write inittable data }
  2354. def.write_child_rtti_data(initrtti);
  2355. if (cs_create_smart in aktmoduleswitches) then
  2356. rttiList.concat(Tai_cut.Create);
  2357. rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
  2358. def.write_rtti_data(initrtti);
  2359. rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
  2360. end;
  2361. end;
  2362. end.
  2363. {
  2364. $Log$
  2365. Revision 1.46 2002-07-23 10:13:23 daniel
  2366. * Added important comment
  2367. Revision 1.45 2002/07/23 09:51:26 daniel
  2368. * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
  2369. are worth comitting.
  2370. Revision 1.44 2002/07/20 17:45:29 daniel
  2371. * Register variables are now possible for global variables too. This is
  2372. important for small programs without procedures.
  2373. Revision 1.43 2002/07/20 11:57:58 florian
  2374. * types.pas renamed to defbase.pas because D6 contains a types
  2375. unit so this would conflicts if D6 programms are compiled
  2376. + Willamette/SSE2 instructions to assembler added
  2377. Revision 1.42 2002/07/11 14:41:31 florian
  2378. * start of the new generic parameter handling
  2379. Revision 1.41 2002/07/10 07:24:40 jonas
  2380. * memory leak fixes from Sergey Korshunoff
  2381. Revision 1.40 2002/07/01 18:46:27 peter
  2382. * internal linker
  2383. * reorganized aasm layer
  2384. Revision 1.39 2002/05/18 13:34:18 peter
  2385. * readded missing revisions
  2386. Revision 1.38 2002/05/16 19:46:45 carl
  2387. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  2388. + try to fix temp allocation (still in ifdef)
  2389. + generic constructor calls
  2390. + start of tassembler / tmodulebase class cleanup
  2391. Revision 1.36 2002/05/12 16:53:15 peter
  2392. * moved entry and exitcode to ncgutil and cgobj
  2393. * foreach gets extra argument for passing local data to the
  2394. iterator function
  2395. * -CR checks also class typecasts at runtime by changing them
  2396. into as
  2397. * fixed compiler to cycle with the -CR option
  2398. * fixed stabs with elf writer, finally the global variables can
  2399. be watched
  2400. * removed a lot of routines from cga unit and replaced them by
  2401. calls to cgobj
  2402. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  2403. u32bit then the other is typecasted also to u32bit without giving
  2404. a rangecheck warning/error.
  2405. * fixed pascal calling method with reversing also the high tree in
  2406. the parast, detected by tcalcst3 test
  2407. Revision 1.35 2002/04/19 15:46:03 peter
  2408. * mangledname rewrite, tprocdef.mangledname is now created dynamicly
  2409. in most cases and not written to the ppu
  2410. * add mangeledname_prefix() routine to generate the prefix of
  2411. manglednames depending on the current procedure, object and module
  2412. * removed static procprefix since the mangledname is now build only
  2413. on demand from tprocdef.mangledname
  2414. Revision 1.34 2002/04/16 16:12:47 peter
  2415. * give error when using enums with jumps as array index
  2416. * allow char as enum value
  2417. Revision 1.33 2002/04/15 19:08:22 carl
  2418. + target_info.size_of_pointer -> pointer_size
  2419. + some cleanup of unused types/variables
  2420. Revision 1.32 2002/04/07 13:37:29 carl
  2421. + change unit use
  2422. Revision 1.31 2002/02/03 09:30:04 peter
  2423. * more fixes for protected handling
  2424. }