symsym.pas 80 KB

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