symsym.inc 60 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 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. {****************************************************************************
  19. TSYM (base for all symtypes)
  20. ****************************************************************************}
  21. constructor tsym.init(const n : string);
  22. begin
  23. left:=nil;
  24. right:=nil;
  25. {$ifdef nextfield}
  26. nextsym:=nil;
  27. {$endif nextfield}
  28. setname(n);
  29. typ:=abstractsym;
  30. properties:=current_object_option;
  31. {$ifdef GDB}
  32. isstabwritten := false;
  33. {$endif GDB}
  34. fileinfo:=tokenpos;
  35. {$ifdef UseBrowser}
  36. defref:=nil;
  37. lastwritten:=nil;
  38. refcount:=0;
  39. if (cs_browser in aktmoduleswitches) and make_ref then
  40. begin
  41. defref:=new(pref,init(defref,@tokenpos));
  42. inc(refcount);
  43. end;
  44. lastref:=defref;
  45. {$endif UseBrowser}
  46. end;
  47. constructor tsym.load;
  48. begin
  49. left:=nil;
  50. right:=nil;
  51. setname(readstring);
  52. typ:=abstractsym;
  53. fillchar(fileinfo,sizeof(fileinfo),0);
  54. if object_options then
  55. properties:=symprop(readbyte)
  56. else
  57. properties:=sp_public;
  58. {$ifdef UseBrowser}
  59. lastref:=nil;
  60. defref:=nil;
  61. lastwritten:=nil;
  62. refcount:=0;
  63. {$endif UseBrowser}
  64. {$ifdef GDB}
  65. isstabwritten := false;
  66. {$endif GDB}
  67. end;
  68. {$ifdef UseBrowser}
  69. procedure tsym.load_references;
  70. var
  71. pos : tfileposinfo;
  72. move_last : boolean;
  73. begin
  74. move_last:=lastwritten=lastref;
  75. while (not current_ppu^.endofentry) do
  76. begin
  77. readposinfo(pos);
  78. inc(refcount);
  79. lastref:=new(pref,init(lastref,@pos));
  80. lastref^.is_written:=true;
  81. if refcount=1 then
  82. defref:=lastref;
  83. end;
  84. if move_last then
  85. lastwritten:=lastref;
  86. end;
  87. { big problem here :
  88. wrong refs were written because of
  89. interface parsing of other units PM
  90. moduleindex must be checked !! }
  91. function tsym.write_references : boolean;
  92. var
  93. ref : pref;
  94. symref_written,move_last : boolean;
  95. begin
  96. write_references:=false;
  97. if lastwritten=lastref then
  98. exit;
  99. { should we update lastref }
  100. move_last:=true;
  101. symref_written:=false;
  102. { write symbol refs }
  103. if assigned(lastwritten) then
  104. ref:=lastwritten
  105. else
  106. ref:=defref;
  107. while assigned(ref) do
  108. begin
  109. if ref^.moduleindex=current_module^.unit_index then
  110. begin
  111. { write address to this symbol }
  112. if not symref_written then
  113. begin
  114. writesymref(@self);
  115. symref_written:=true;
  116. end;
  117. writeposinfo(ref^.posinfo);
  118. ref^.is_written:=true;
  119. if move_last then
  120. lastwritten:=ref;
  121. end
  122. else if not ref^.is_written then
  123. move_last:=false
  124. else if move_last then
  125. lastwritten:=ref;
  126. ref:=ref^.nextref;
  127. end;
  128. if symref_written then
  129. current_ppu^.writeentry(ibsymref);
  130. write_references:=symref_written;
  131. end;
  132. procedure tsym.add_to_browserlog;
  133. begin
  134. if assigned(defref) then
  135. begin
  136. Browse.AddLog('***'+name+'***');
  137. Browse.AddLogRefs(defref);
  138. end;
  139. end;
  140. {$endif UseBrowser}
  141. destructor tsym.done;
  142. begin
  143. {$ifdef tp}
  144. if not(use_big) then
  145. {$endif tp}
  146. strdispose(_name);
  147. {$ifdef UseBrowser}
  148. if assigned(defref) then
  149. dispose(defref,done);
  150. {$endif UseBrowser}
  151. if assigned(left) then
  152. dispose(left,done);
  153. if assigned(right) then
  154. dispose(right,done);
  155. end;
  156. procedure tsym.write;
  157. begin
  158. writestring(name);
  159. if object_options then
  160. writebyte(byte(properties));
  161. end;
  162. procedure tsym.deref;
  163. begin
  164. end;
  165. function tsym.name : string;
  166. {$ifdef tp}
  167. var
  168. s : string;
  169. b : byte;
  170. {$endif}
  171. begin
  172. {$ifdef tp}
  173. if use_big then
  174. begin
  175. symbolstream.seek(longint(_name));
  176. symbolstream.read(b,1);
  177. symbolstream.read(s[1],b);
  178. s[0]:=chr(b);
  179. name:=s;
  180. end
  181. else
  182. {$endif}
  183. if assigned(_name) then
  184. name:=strpas(_name)
  185. else
  186. name:='';
  187. end;
  188. function tsym.mangledname : string;
  189. begin
  190. mangledname:=name;
  191. end;
  192. procedure tsym.setname(const s : string);
  193. begin
  194. setstring(_name,s);
  195. end;
  196. { for most symbol types there is nothing to do at all }
  197. procedure tsym.insert_in_data;
  198. begin
  199. end;
  200. {$ifdef GDB}
  201. function tsym.stabstring : pchar;
  202. begin
  203. stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+
  204. tostr(fileinfo.line)+',0');
  205. end;
  206. procedure tsym.concatstabto(asmlist : paasmoutput);
  207. var stab_str : pchar;
  208. begin
  209. if not isstabwritten then
  210. begin
  211. stab_str := stabstring;
  212. if asmlist = debuglist then do_count_dbx := true;
  213. { count_dbx(stab_str); moved to GDB.PAS }
  214. asmlist^.concat(new(pai_stabs,init(stab_str)));
  215. isstabwritten:=true;
  216. end;
  217. end;
  218. {$endif GDB}
  219. {****************************************************************************
  220. TLABELSYM
  221. ****************************************************************************}
  222. constructor tlabelsym.init(const n : string; l : plabel);
  223. begin
  224. inherited init(n);
  225. typ:=labelsym;
  226. number:=l;
  227. number^.is_used:=false;
  228. number^.is_set:=true;
  229. number^.refcount:=0;
  230. defined:=false;
  231. end;
  232. constructor tlabelsym.load;
  233. begin
  234. tsym.load;
  235. typ:=labelsym;
  236. { this is all dummy
  237. it is only used for local browsing }
  238. number:=nil;
  239. defined:=true;
  240. end;
  241. destructor tlabelsym.done;
  242. begin
  243. inherited done;
  244. end;
  245. function tlabelsym.mangledname : string;
  246. begin
  247. { this also sets the is_used field }
  248. mangledname:=lab2str(number);
  249. end;
  250. procedure tlabelsym.write;
  251. begin
  252. if owner^.symtabletype in [unitsymtable,globalsymtable] then
  253. Message(sym_e_ill_label_decl)
  254. else
  255. begin
  256. tsym.write;
  257. current_ppu^.writeentry(iblabelsym);
  258. end;
  259. end;
  260. {****************************************************************************
  261. TUNITSYM
  262. ****************************************************************************}
  263. constructor tunitsym.init(const n : string;ref : punitsymtable);
  264. var
  265. old_make_ref : boolean;
  266. begin
  267. old_make_ref:=make_ref;
  268. make_ref:=false;
  269. inherited init(n);
  270. make_ref:=old_make_ref;
  271. typ:=unitsym;
  272. unitsymtable:=ref;
  273. prevsym:=ref^.unitsym;
  274. ref^.unitsym:=@self;
  275. refs:=0;
  276. end;
  277. constructor tunitsym.load;
  278. begin
  279. tsym.load;
  280. typ:=unitsym;
  281. unitsymtable:=punitsymtable(current_module^.globalsymtable);
  282. prevsym:=nil;
  283. end;
  284. destructor tunitsym.done;
  285. begin
  286. if assigned(unitsymtable) and (unitsymtable^.unitsym=@self) then
  287. unitsymtable^.unitsym:=prevsym;
  288. inherited done;
  289. end;
  290. procedure tunitsym.write;
  291. begin
  292. tsym.write;
  293. current_ppu^.writeentry(ibunitsym);
  294. end;
  295. {$ifdef GDB}
  296. procedure tunitsym.concatstabto(asmlist : paasmoutput);
  297. begin
  298. {Nothing to write to stabs !}
  299. end;
  300. {$endif GDB}
  301. {****************************************************************************
  302. TPROCSYM
  303. ****************************************************************************}
  304. constructor tprocsym.init(const n : string);
  305. begin
  306. tsym.init(n);
  307. typ:=procsym;
  308. definition:=nil;
  309. owner:=nil;
  310. {$ifdef GDB}
  311. is_global := false;
  312. {$endif GDB}
  313. end;
  314. constructor tprocsym.load;
  315. begin
  316. tsym.load;
  317. typ:=procsym;
  318. definition:=pprocdef(readdefref);
  319. {$ifdef GDB}
  320. is_global := false;
  321. {$endif GDB}
  322. end;
  323. destructor tprocsym.done;
  324. begin
  325. check_forward;
  326. tsym.done;
  327. end;
  328. function tprocsym.mangledname : string;
  329. begin
  330. mangledname:=definition^.mangledname;
  331. end;
  332. function tprocsym.demangledname:string;
  333. begin
  334. demangledname:=name+definition^.demangled_paras;
  335. end;
  336. procedure tprocsym.write_parameter_lists;
  337. var
  338. p : pprocdef;
  339. begin
  340. p:=definition;
  341. while assigned(p) do
  342. begin
  343. { force the error to be printed }
  344. Verbose.Message1(sym_b_param_list,name+p^.demangled_paras);
  345. p:=p^.nextoverloaded;
  346. end;
  347. end;
  348. procedure tprocsym.check_forward;
  349. var
  350. pd : pprocdef;
  351. oldaktfilepos : tfileposinfo;
  352. begin
  353. { don't check if errors !! }
  354. if status.errorcount>0 then
  355. exit;
  356. pd:=definition;
  357. while assigned(pd) do
  358. begin
  359. if pd^.forwarddef then
  360. begin
  361. oldaktfilepos:=aktfilepos;
  362. aktfilepos:=fileinfo;
  363. if assigned(pd^._class) then
  364. Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+demangledparas(pd^.demangled_paras))
  365. else
  366. Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras);
  367. aktfilepos:=oldaktfilepos;
  368. end;
  369. pd:=pd^.nextoverloaded;
  370. end;
  371. end;
  372. procedure tprocsym.deref;
  373. var
  374. t : ttoken;
  375. last : pprocdef;
  376. begin
  377. resolvedef(pdef(definition));
  378. if (definition^.options and pooperator) <> 0 then
  379. begin
  380. last:=definition;
  381. while assigned(last^.nextoverloaded) do
  382. last:=last^.nextoverloaded;
  383. for t:=first_overloaded to last_overloaded do
  384. if (name=overloaded_names[t]) then
  385. begin
  386. if assigned(overloaded_operators[t]) then
  387. last^.nextoverloaded:=overloaded_operators[t]^.definition;
  388. overloaded_operators[t]:=@self;
  389. end;
  390. end;
  391. end;
  392. procedure tprocsym.write;
  393. begin
  394. tsym.write;
  395. writedefref(pdef(definition));
  396. current_ppu^.writeentry(ibprocsym);
  397. end;
  398. {$ifdef UseBrowser}
  399. procedure tprocsym.load_references;
  400. var
  401. prdef : pprocdef;
  402. begin
  403. inherited load_references;
  404. prdef:=definition;
  405. { take care about operators !! }
  406. while assigned(prdef) and (prdef^.owner=definition^.owner) do
  407. begin
  408. prdef^.load_references;
  409. prdef:=prdef^.nextoverloaded;
  410. end;
  411. end;
  412. function tprocsym.write_references : boolean;
  413. var
  414. prdef : pprocdef;
  415. begin
  416. write_references:=false;
  417. if not inherited write_references then
  418. exit;
  419. write_references:=true;
  420. prdef:=definition;
  421. while assigned(prdef) and (prdef^.owner=definition^.owner) do
  422. begin
  423. prdef^.write_references;
  424. prdef:=prdef^.nextoverloaded;
  425. end;
  426. end;
  427. procedure tprocsym.add_to_browserlog;
  428. var
  429. prdef : pprocdef;
  430. begin
  431. inherited add_to_browserlog;
  432. prdef:=definition;
  433. while assigned(prdef) do
  434. begin
  435. pprocdef(prdef)^.add_to_browserlog;
  436. prdef:=pprocdef(prdef)^.nextoverloaded;
  437. end;
  438. end;
  439. {$endif UseBrowser}
  440. {$ifdef GDB}
  441. function tprocsym.stabstring : pchar;
  442. Var RetType : Char;
  443. Obj,Info : String;
  444. stabsstr : string;
  445. p : pchar;
  446. begin
  447. obj := name;
  448. info := '';
  449. if is_global then
  450. RetType := 'F'
  451. else
  452. RetType := 'f';
  453. if assigned(owner) then
  454. begin
  455. if (owner^.symtabletype = objectsymtable) then
  456. obj := owner^.name^+'__'+name;
  457. if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then
  458. info := ','+name+','+owner^.name^;
  459. end;
  460. stabsstr:=definition^.mangledname;
  461. getmem(p,length(stabsstr)+255);
  462. strpcopy(p,'"'+obj+':'+RetType
  463. +definition^.retdef^.numberstring+info+'",'+tostr(n_function)
  464. +',0,'+
  465. tostr(aktfilepos.line)
  466. +',');
  467. strpcopy(strend(p),stabsstr);
  468. stabstring:=strnew(p);
  469. freemem(p,length(stabsstr)+255);
  470. end;
  471. procedure tprocsym.concatstabto(asmlist : paasmoutput);
  472. begin
  473. if (definition^.options and pointernproc) <> 0 then exit;
  474. if not isstabwritten then
  475. asmlist^.concat(new(pai_stabs,init(stabstring)));
  476. isstabwritten := true;
  477. if assigned(definition^.parast) then
  478. definition^.parast^.concatstabto(asmlist);
  479. if assigned(definition^.localst) then
  480. definition^.localst^.concatstabto(asmlist);
  481. definition^.is_def_stab_written := true;
  482. end;
  483. {$endif GDB}
  484. {****************************************************************************
  485. TPROGRAMSYM
  486. ****************************************************************************}
  487. constructor tprogramsym.init(const n : string);
  488. begin
  489. inherited init(n);
  490. typ:=programsym;
  491. end;
  492. {****************************************************************************
  493. TERRORSYM
  494. ****************************************************************************}
  495. constructor terrorsym.init;
  496. begin
  497. inherited init('');
  498. typ:=errorsym;
  499. end;
  500. {****************************************************************************
  501. TPROPERTYSYM
  502. ****************************************************************************}
  503. constructor tpropertysym.init(const n : string);
  504. begin
  505. inherited init(n);
  506. typ:=propertysym;
  507. options:=0;
  508. proptype:=nil;
  509. readaccessdef:=nil;
  510. writeaccessdef:=nil;
  511. readaccesssym:=nil;
  512. writeaccesssym:=nil;
  513. storedsym:=nil;
  514. storeddef:=nil;
  515. index:=0;
  516. default:=0;
  517. end;
  518. destructor tpropertysym.done;
  519. begin
  520. inherited done;
  521. end;
  522. constructor tpropertysym.load;
  523. begin
  524. inherited load;
  525. typ:=propertysym;
  526. proptype:=readdefref;
  527. options:=readlong;
  528. index:=readlong;
  529. default:=readlong;
  530. { it's hack ... }
  531. readaccesssym:=psym(stringdup(readstring));
  532. writeaccesssym:=psym(stringdup(readstring));
  533. storedsym:=psym(stringdup(readstring));
  534. { now the defs: }
  535. readaccessdef:=readdefref;
  536. writeaccessdef:=readdefref;
  537. storeddef:=readdefref;
  538. end;
  539. procedure tpropertysym.deref;
  540. begin
  541. resolvedef(proptype);
  542. resolvedef(readaccessdef);
  543. resolvedef(writeaccessdef);
  544. resolvedef(storeddef);
  545. { solve the hack we did in load: }
  546. if pstring(readaccesssym)^<>'' then
  547. begin
  548. srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(readaccesssym)^);
  549. if not(assigned(srsym)) then
  550. srsym:=generrorsym;
  551. end
  552. else
  553. srsym:=nil;
  554. stringdispose(pstring(readaccesssym));
  555. readaccesssym:=srsym;
  556. if pstring(writeaccesssym)^<>'' then
  557. begin
  558. srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(writeaccesssym)^);
  559. if not(assigned(srsym)) then
  560. srsym:=generrorsym;
  561. end
  562. else
  563. srsym:=nil;
  564. stringdispose(pstring(writeaccesssym));
  565. writeaccesssym:=srsym;
  566. if pstring(storedsym)^<>'' then
  567. begin
  568. srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(storedsym)^);
  569. if not(assigned(srsym)) then
  570. srsym:=generrorsym;
  571. end
  572. else
  573. srsym:=nil;
  574. stringdispose(pstring(storedsym));
  575. storedsym:=srsym;
  576. end;
  577. function tpropertysym.getsize : longint;
  578. begin
  579. getsize:=0;
  580. end;
  581. procedure tpropertysym.write;
  582. begin
  583. tsym.write;
  584. writedefref(proptype);
  585. writelong(options);
  586. writelong(index);
  587. writelong(default);
  588. if assigned(readaccesssym) then
  589. writestring(readaccesssym^.name)
  590. else
  591. writestring('');
  592. if assigned(writeaccesssym) then
  593. writestring(writeaccesssym^.name)
  594. else
  595. writestring('');
  596. if assigned(storedsym) then
  597. writestring(storedsym^.name)
  598. else
  599. writestring('');
  600. writedefref(readaccessdef);
  601. writedefref(writeaccessdef);
  602. writedefref(storeddef);
  603. current_ppu^.writeentry(ibpropertysym);
  604. end;
  605. {$ifdef GDB}
  606. function tpropertysym.stabstring : pchar;
  607. begin
  608. { !!!! don't know how to handle }
  609. stabstring:=strpnew('');
  610. end;
  611. procedure tpropertysym.concatstabto(asmlist : paasmoutput);
  612. begin
  613. { !!!! don't know how to handle }
  614. end;
  615. {$endif GDB}
  616. {****************************************************************************
  617. TFUNCRETSYM
  618. ****************************************************************************}
  619. constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});
  620. begin
  621. tsym.init(n);
  622. typ:=funcretsym;
  623. funcretprocinfo:=approcinfo;
  624. funcretdef:=pprocinfo(approcinfo)^.retdef;
  625. { address valid for ret in param only }
  626. { otherwise set by insert }
  627. address:=pprocinfo(approcinfo)^.retoffset;
  628. end;
  629. {$ifdef GDB}
  630. procedure tfuncretsym.concatstabto(asmlist : paasmoutput);
  631. begin
  632. { Nothing to do here, it is done in genexitcode }
  633. end;
  634. {$endif GDB}
  635. {****************************************************************************
  636. TABSOLUTESYM
  637. ****************************************************************************}
  638. constructor tabsolutesym.init(const n : string;p : pdef);
  639. begin
  640. inherited init(n,p);
  641. typ:=absolutesym;
  642. end;
  643. constructor tabsolutesym.load;
  644. begin
  645. tvarsym.load;
  646. typ:=absolutesym;
  647. ref:=nil;
  648. address:=0;
  649. asmname:=nil;
  650. abstyp:=absolutetyp(readbyte);
  651. absseg:=false;
  652. case abstyp of
  653. tovar : begin
  654. asmname:=stringdup(readstring);
  655. ref:=srsym;
  656. end;
  657. toasm : asmname:=stringdup(readstring);
  658. toaddr : begin
  659. address:=readlong;
  660. absseg:=boolean(readbyte);
  661. end;
  662. end;
  663. end;
  664. procedure tabsolutesym.write;
  665. begin
  666. tsym.write;
  667. writebyte(byte(varspez));
  668. if read_member then
  669. writelong(address);
  670. writedefref(definition);
  671. writebyte(var_options and (not vo_regable));
  672. writebyte(byte(abstyp));
  673. case abstyp of
  674. tovar : writestring(ref^.name);
  675. toasm : writestring(asmname^);
  676. toaddr : begin
  677. writelong(address);
  678. writebyte(byte(absseg));
  679. end;
  680. end;
  681. current_ppu^.writeentry(ibabsolutesym);
  682. end;
  683. procedure tabsolutesym.deref;
  684. begin
  685. resolvedef(definition);
  686. if (abstyp=tovar) and (asmname<>nil) then
  687. begin
  688. { search previous loaded symtables }
  689. getsym(asmname^,false);
  690. if not(assigned(srsym)) then
  691. getsymonlyin(owner,asmname^);
  692. if not(assigned(srsym)) then
  693. srsym:=generrorsym;
  694. ref:=srsym;
  695. stringdispose(asmname);
  696. end;
  697. end;
  698. function tabsolutesym.mangledname : string;
  699. begin
  700. case abstyp of
  701. tovar : mangledname:=ref^.mangledname;
  702. toasm : mangledname:=asmname^;
  703. toaddr : mangledname:='$'+tostr(address);
  704. else
  705. internalerror(10002);
  706. end;
  707. end;
  708. procedure tabsolutesym.insert_in_data;
  709. begin
  710. end;
  711. {$ifdef GDB}
  712. procedure tabsolutesym.concatstabto(asmlist : paasmoutput);
  713. begin
  714. { I don't know how to handle this !! }
  715. end;
  716. {$endif GDB}
  717. {****************************************************************************
  718. TVARSYM
  719. ****************************************************************************}
  720. constructor tvarsym.init(const n : string;p : pdef);
  721. begin
  722. tsym.init(n);
  723. typ:=varsym;
  724. definition:=p;
  725. _mangledname:=nil;
  726. varspez:=vs_value;
  727. address:=0;
  728. localaddress:=-1;
  729. islocalcopy:=false;
  730. refs:=0;
  731. is_valid := 1;
  732. var_options:=0;
  733. { can we load the value into a register ? }
  734. case p^.deftype of
  735. pointerdef,
  736. enumdef,
  737. procvardef : var_options:=var_options or vo_regable;
  738. orddef : case porddef(p)^.typ of
  739. u8bit,u16bit,u32bit,
  740. bool8bit,bool16bit,bool32bit,
  741. s8bit,s16bit,s32bit :
  742. var_options:=var_options or vo_regable;
  743. else
  744. var_options:=var_options and not vo_regable;
  745. end;
  746. else
  747. var_options:=var_options and not vo_regable;
  748. end;
  749. reg:=R_NO;
  750. end;
  751. constructor tvarsym.init_dll(const n : string;p : pdef);
  752. begin
  753. { The tvarsym is necessary for 0.99.5 (PFV) }
  754. tvarsym.init(n,p);
  755. var_options:=var_options or vo_is_dll_var;
  756. end;
  757. constructor tvarsym.init_C(const n,mangled : string;p : pdef);
  758. begin
  759. { The tvarsym is necessary for 0.99.5 (PFV) }
  760. tvarsym.init(n,p);
  761. var_options:=var_options or vo_is_C_var;
  762. setmangledname(mangled);
  763. end;
  764. constructor tvarsym.load;
  765. begin
  766. tsym.load;
  767. typ:=varsym;
  768. _mangledname:=nil;
  769. reg:=R_NO;
  770. refs := 0;
  771. is_valid := 1;
  772. varspez:=tvarspez(readbyte);
  773. if read_member then
  774. address:=readlong
  775. else
  776. address:=0;
  777. localaddress:=-1;
  778. islocalcopy:=false;
  779. definition:=readdefref;
  780. var_options:=readbyte;
  781. if (var_options and vo_is_C_var)<>0 then
  782. setmangledname(readstring);
  783. end;
  784. procedure tvarsym.deref;
  785. begin
  786. resolvedef(definition);
  787. end;
  788. procedure tvarsym.write;
  789. begin
  790. tsym.write;
  791. writebyte(byte(varspez));
  792. if read_member then
  793. writelong(address);
  794. writedefref(definition);
  795. { symbols which are load are never candidates for a register,
  796. turn of the regable }
  797. writebyte(var_options and (not vo_regable));
  798. if (var_options and vo_is_C_var)<>0 then
  799. writestring(mangledname);
  800. current_ppu^.writeentry(ibvarsym);
  801. end;
  802. procedure tvarsym.setmangledname(const s : string);
  803. begin
  804. _mangledname:=strpnew(s);
  805. end;
  806. function tvarsym.mangledname : string;
  807. var
  808. prefix : string;
  809. begin
  810. if assigned(_mangledname) then
  811. begin
  812. mangledname:=strpas(_mangledname);
  813. exit;
  814. end;
  815. case owner^.symtabletype of
  816. staticsymtable : if (cs_smartlink in aktmoduleswitches) then
  817. prefix:='_'+owner^.name^+'$$$_'
  818. else
  819. prefix:='_';
  820. unitsymtable,
  821. globalsymtable : prefix:='U_'+owner^.name^+'_';
  822. else
  823. Message(sym_e_invalid_call_tvarsymmangledname);
  824. end;
  825. mangledname:=prefix+name;
  826. end;
  827. function tvarsym.getsize : longint;
  828. begin
  829. if assigned(definition) and (varspez=vs_value) then
  830. getsize:=definition^.size
  831. else
  832. getsize:=0;
  833. end;
  834. function tvarsym.getpushsize : longint;
  835. begin
  836. if assigned(definition) then
  837. begin
  838. case varspez of
  839. vs_var :
  840. begin
  841. { open arrays push also the high valye }
  842. if is_open_array(definition) or
  843. is_open_string(definition) then
  844. getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
  845. else
  846. getpushsize:=target_os.size_of_pointer;
  847. end;
  848. vs_value,
  849. vs_const :
  850. begin
  851. case definition^.deftype of
  852. setdef,
  853. stringdef,
  854. recorddef,
  855. objectdef :
  856. getpushsize:=target_os.size_of_pointer;
  857. arraydef :
  858. if is_open_array(definition) then
  859. getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
  860. else
  861. getpushsize:=target_os.size_of_pointer;
  862. else
  863. getpushsize:=definition^.size;
  864. end;
  865. end;
  866. end;
  867. end
  868. else
  869. getpushsize:=0;
  870. end;
  871. procedure tvarsym.insert_in_data;
  872. var
  873. l,modulo : longint;
  874. begin
  875. if (var_options and vo_is_external)<>0 then
  876. exit;
  877. { handle static variables of objects especially }
  878. if read_member and (owner^.symtabletype=objectsymtable) and
  879. ((properties and sp_static)<>0) then
  880. begin
  881. { the data filed is generated in parser.pas
  882. with a tobject_FIELDNAME variable }
  883. { this symbol can't be loaded to a register }
  884. var_options:=var_options and not vo_regable;
  885. end
  886. else
  887. if not(read_member) then
  888. begin
  889. { made problems with parameters etc. ! (FK) }
  890. { check for instance of an abstract object or class }
  891. {
  892. if (pvarsym(sym)^.definition^.deftype=objectdef) and
  893. ((pobjectdef(pvarsym(sym)^.definition)^.options and oo_is_abstract)<>0) then
  894. Message(sym_e_no_instance_of_abstract_object);
  895. }
  896. l:=getsize;
  897. case owner^.symtabletype of
  898. stt_exceptsymtable:
  899. { can contain only one symbol, address calculated later }
  900. ;
  901. localsymtable :
  902. begin
  903. is_valid := 0;
  904. modulo:=owner^.datasize and 3;
  905. {$ifdef m68k}
  906. { word alignment required for motorola }
  907. if (l=1) then
  908. l:=2
  909. else
  910. {$endif}
  911. if (l>=4) and (modulo<>0) then
  912. inc(l,4-modulo)
  913. else
  914. if (l>=2) and ((modulo and 1)<>0) then
  915. inc(l,2-(modulo and 1));
  916. inc(owner^.datasize,l);
  917. address:=owner^.datasize;
  918. end;
  919. staticsymtable :
  920. begin
  921. if (cs_smartlink in aktmoduleswitches) then
  922. bsssegment^.concat(new(pai_cut,init));
  923. {$ifdef GDB}
  924. if cs_debuginfo in aktmoduleswitches then
  925. concatstabto(bsssegment);
  926. {$endif GDB}
  927. if (cs_smartlink in aktmoduleswitches) or
  928. ((var_options and vo_is_c_var)<>0) then
  929. bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)))
  930. else
  931. bsssegment^.concat(new(pai_datablock,init(mangledname,l)));
  932. { increase datasize }
  933. inc(owner^.datasize,l);
  934. { this symbol can't be loaded to a register }
  935. var_options:=var_options and not vo_regable;
  936. end;
  937. globalsymtable :
  938. begin
  939. if (cs_smartlink in aktmoduleswitches) then
  940. bsssegment^.concat(new(pai_cut,init));
  941. {$ifdef GDB}
  942. if cs_debuginfo in aktmoduleswitches then
  943. concatstabto(bsssegment);
  944. {$endif GDB}
  945. bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)));
  946. inc(owner^.datasize,l);
  947. { this symbol can't be loaded to a register }
  948. var_options:=var_options and not vo_regable;
  949. end;
  950. recordsymtable,
  951. objectsymtable :
  952. begin
  953. { this symbol can't be loaded to a register }
  954. var_options:=var_options and not vo_regable;
  955. { align record and object fields }
  956. if (l=1) or (aktpackrecords=1) then
  957. begin
  958. address:=owner^.datasize;
  959. inc(owner^.datasize,l)
  960. end
  961. else
  962. if (l=2) or (aktpackrecords=2) then
  963. begin
  964. owner^.datasize:=(owner^.datasize+1) and (not 1);
  965. address:=owner^.datasize;
  966. inc(owner^.datasize,l)
  967. end
  968. else
  969. if (l<=4) or (aktpackrecords=4) then
  970. begin
  971. owner^.datasize:=(owner^.datasize+3) and (not 3);
  972. address:=owner^.datasize;
  973. inc(owner^.datasize,l);
  974. end
  975. else
  976. if (l<=8) or (aktpackrecords=8) then
  977. begin
  978. owner^.datasize:=(owner^.datasize+7) and (not 7);
  979. address:=owner^.datasize;
  980. inc(owner^.datasize,l);
  981. end
  982. else
  983. if (l<=16) or (aktpackrecords=16) then
  984. begin
  985. owner^.datasize:=(owner^.datasize+15) and (not 15);
  986. address:=owner^.datasize;
  987. inc(owner^.datasize,l);
  988. end
  989. else
  990. if (l<=32) or (aktpackrecords=32) then
  991. begin
  992. owner^.datasize:=(owner^.datasize+31) and (not 31);
  993. address:=owner^.datasize;
  994. inc(owner^.datasize,l);
  995. end;
  996. end;
  997. parasymtable :
  998. begin
  999. { here we need the size of a push instead of the
  1000. size of the data }
  1001. l:=getpushsize;
  1002. address:=owner^.datasize;
  1003. owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment);
  1004. end
  1005. else
  1006. begin
  1007. modulo:=owner^.datasize and 3 ;
  1008. if (l>=4) and (modulo<>0) then
  1009. inc(owner^.datasize,4-modulo)
  1010. else
  1011. if (l>=2) and ((modulo and 1)<>0) then
  1012. inc(owner^.datasize);
  1013. address:=owner^.datasize;
  1014. inc(owner^.datasize,l);
  1015. end;
  1016. end;
  1017. end;
  1018. end;
  1019. {$ifdef GDB}
  1020. function tvarsym.stabstring : pchar;
  1021. var
  1022. st : char;
  1023. begin
  1024. if (owner^.symtabletype = objectsymtable) and
  1025. ((properties and sp_static)<>0) then
  1026. begin
  1027. if (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S';
  1028. stabstring := strpnew('"'+owner^.name^+'__'+name+':'+
  1029. +definition^.numberstring+'",'+
  1030. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1031. end
  1032. else if (owner^.symtabletype = globalsymtable) or
  1033. (owner^.symtabletype = unitsymtable) then
  1034. begin
  1035. { Here we used S instead of
  1036. because with G GDB doesn't look at the address field
  1037. but searches the same name or with a leading underscore
  1038. but these names don't exist in pascal !}
  1039. if (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S';
  1040. stabstring := strpnew('"'+name+':'+st
  1041. +definition^.numberstring+'",'+
  1042. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1043. end
  1044. else if owner^.symtabletype = staticsymtable then
  1045. begin
  1046. stabstring := strpnew('"'+name+':S'
  1047. +definition^.numberstring+'",'+
  1048. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1049. end
  1050. else if (owner^.symtabletype=parasymtable) then
  1051. begin
  1052. case varspez of
  1053. vs_var : st := 'v';
  1054. vs_value,
  1055. vs_const : if push_addr_param(definition) then
  1056. st := 'v' { should be 'i' but 'i' doesn't work }
  1057. else
  1058. st := 'p';
  1059. end;
  1060. stabstring := strpnew('"'+name+':'+st
  1061. +definition^.numberstring+'",'+
  1062. tostr(N_PSYM)+',0,'+tostr(fileinfo.line)+','+
  1063. tostr(address+owner^.call_offset));
  1064. {offset to ebp => will not work if the framepointer is esp
  1065. so some optimizing will make things harder to debug }
  1066. end
  1067. else if (owner^.symtabletype=localsymtable) then
  1068. {$ifdef i386}
  1069. if reg<>R_NO then
  1070. begin
  1071. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1072. { this is the register order for GDB}
  1073. stabstring:=strpnew('"'+name+':r'
  1074. +definition^.numberstring+'",'+
  1075. tostr(N_RSYM)+',0,'+
  1076. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1077. end
  1078. else
  1079. {$endif i386}
  1080. stabstring := strpnew('"'+name+':'
  1081. +definition^.numberstring+'",'+
  1082. tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address))
  1083. else
  1084. stabstring := inherited stabstring;
  1085. end;
  1086. procedure tvarsym.concatstabto(asmlist : paasmoutput);
  1087. {$ifdef i386}
  1088. var stab_str : pchar;
  1089. {$endif i386}
  1090. begin
  1091. inherited concatstabto(asmlist);
  1092. {$ifdef i386}
  1093. if (owner^.symtabletype=parasymtable) and
  1094. (reg<>R_NO) then
  1095. begin
  1096. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1097. { this is the register order for GDB}
  1098. stab_str:=strpnew('"'+name+':r'
  1099. +definition^.numberstring+'",'+
  1100. tostr(N_RSYM)+',0,'+
  1101. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1102. asmlist^.concat(new(pai_stabs,init(stab_str)));
  1103. end;
  1104. {$endif i386}
  1105. end;
  1106. {$endif GDB}
  1107. destructor tvarsym.done;
  1108. begin
  1109. strdispose(_mangledname);
  1110. inherited done;
  1111. end;
  1112. {****************************************************************************
  1113. TTYPEDCONSTSYM
  1114. *****************************************************************************}
  1115. constructor ttypedconstsym.init(const n : string;p : pdef);
  1116. begin
  1117. tsym.init(n);
  1118. typ:=typedconstsym;
  1119. definition:=p;
  1120. prefix:=stringdup(procprefix);
  1121. end;
  1122. constructor ttypedconstsym.load;
  1123. begin
  1124. tsym.load;
  1125. typ:=typedconstsym;
  1126. definition:=readdefref;
  1127. prefix:=stringdup(readstring);
  1128. end;
  1129. destructor ttypedconstsym.done;
  1130. begin
  1131. stringdispose(prefix);
  1132. tsym.done;
  1133. end;
  1134. function ttypedconstsym.mangledname : string;
  1135. begin
  1136. mangledname:='TC_'+prefix^+'_'+name;
  1137. end;
  1138. function ttypedconstsym.getsize : longint;
  1139. begin
  1140. if assigned(definition) then
  1141. getsize:=definition^.size
  1142. else
  1143. getsize:=0;
  1144. end;
  1145. procedure ttypedconstsym.deref;
  1146. begin
  1147. resolvedef(definition);
  1148. end;
  1149. procedure ttypedconstsym.write;
  1150. begin
  1151. tsym.write;
  1152. writedefref(definition);
  1153. writestring(prefix^);
  1154. current_ppu^.writeentry(ibtypedconstsym);
  1155. end;
  1156. { for most symbol types ther is nothing to do at all }
  1157. procedure ttypedconstsym.insert_in_data;
  1158. begin
  1159. { here there is a problem for ansistrings !! }
  1160. { we must write the label only after the 12 header bytes (PM)
  1161. if not is_ansistring(definition) then
  1162. }
  1163. { solved, the ansis string is moved to consts (FK) }
  1164. really_insert_in_data;
  1165. end;
  1166. procedure ttypedconstsym.really_insert_in_data;
  1167. begin
  1168. if owner^.symtabletype=globalsymtable then
  1169. begin
  1170. if (cs_smartlink in aktmoduleswitches) then
  1171. datasegment^.concat(new(pai_cut,init));
  1172. {$ifdef GDB}
  1173. if cs_debuginfo in aktmoduleswitches then
  1174. concatstabto(datasegment);
  1175. {$endif GDB}
  1176. datasegment^.concat(new(pai_symbol,init_global(mangledname)));
  1177. end
  1178. else
  1179. if owner^.symtabletype<>unitsymtable then
  1180. begin
  1181. if (cs_smartlink in aktmoduleswitches) then
  1182. datasegment^.concat(new(pai_cut,init));
  1183. {$ifdef GDB}
  1184. if cs_debuginfo in aktmoduleswitches then
  1185. concatstabto(datasegment);
  1186. {$endif GDB}
  1187. if (cs_smartlink in aktmoduleswitches) then
  1188. datasegment^.concat(new(pai_symbol,init_global(mangledname)))
  1189. else
  1190. datasegment^.concat(new(pai_symbol,init(mangledname)));
  1191. end;
  1192. end;
  1193. {$ifdef GDB}
  1194. function ttypedconstsym.stabstring : pchar;
  1195. var
  1196. st : char;
  1197. begin
  1198. if (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then
  1199. st := 'G'
  1200. else
  1201. st := 'S';
  1202. stabstring := strpnew('"'+name+':'+st+
  1203. definition^.numberstring+'",'+tostr(n_STSYM)+',0,'+
  1204. tostr(fileinfo.line)+','+mangledname);
  1205. end;
  1206. {$endif GDB}
  1207. {****************************************************************************
  1208. TCONSTSYM
  1209. ****************************************************************************}
  1210. constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);
  1211. begin
  1212. tsym.init(n);
  1213. typ:=constsym;
  1214. definition:=def;
  1215. consttype:=t;
  1216. value:=v;
  1217. end;
  1218. constructor tconstsym.load;
  1219. var
  1220. pd : pbestreal;
  1221. ps : pnormalset;
  1222. begin
  1223. tsym.load;
  1224. typ:=constsym;
  1225. consttype:=tconsttype(readbyte);
  1226. case consttype of
  1227. constint,
  1228. constbool,
  1229. constchar : value:=readlong;
  1230. constord : begin
  1231. definition:=readdefref;
  1232. value:=readlong;
  1233. end;
  1234. conststring : value:=longint(stringdup(readstring));
  1235. constreal : begin
  1236. new(pd);
  1237. pd^:=readreal;
  1238. value:=longint(pd);
  1239. end;
  1240. constset : begin
  1241. definition:=readdefref;
  1242. new(ps);
  1243. readnormalset(ps^);
  1244. value:=longint(ps);
  1245. end;
  1246. constnil : ;
  1247. else
  1248. Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
  1249. end;
  1250. end;
  1251. destructor tconstsym.done;
  1252. begin
  1253. case consttype of
  1254. conststring : stringdispose(pstring(value));
  1255. constreal : dispose(pbestreal(value));
  1256. constset : dispose(pnormalset(value));
  1257. end;
  1258. inherited done;
  1259. end;
  1260. function tconstsym.mangledname : string;
  1261. begin
  1262. mangledname:=name;
  1263. end;
  1264. procedure tconstsym.deref;
  1265. begin
  1266. if consttype in [constord,constset] then
  1267. resolvedef(pdef(definition));
  1268. end;
  1269. procedure tconstsym.write;
  1270. begin
  1271. tsym.write;
  1272. writebyte(byte(consttype));
  1273. case consttype of
  1274. constnil : ;
  1275. constint,
  1276. constbool,
  1277. constchar : writelong(value);
  1278. constord : begin
  1279. writedefref(definition);
  1280. writelong(value);
  1281. end;
  1282. conststring : writestring(pstring(value)^);
  1283. constreal : writereal(pbestreal(value)^);
  1284. constset : begin
  1285. writedefref(definition);
  1286. writenormalset(pointer(value)^);
  1287. end;
  1288. else
  1289. internalerror(13);
  1290. end;
  1291. current_ppu^.writeentry(ibconstsym);
  1292. end;
  1293. {$ifdef GDB}
  1294. function tconstsym.stabstring : pchar;
  1295. var st : string;
  1296. begin
  1297. {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
  1298. case consttype of
  1299. conststring : begin
  1300. { I had to remove ibm2ascii !! }
  1301. st := pstring(value)^;
  1302. {st := ibm2ascii(pstring(value)^);}
  1303. st := 's'''+st+'''';
  1304. end;
  1305. constbool, constint, constord, constchar : st := 'i'+tostr(value);
  1306. constreal : begin
  1307. system.str(pbestreal(value)^,st);
  1308. st := 'r'+st;
  1309. end;
  1310. { if we don't know just put zero !! }
  1311. else st:='i0';
  1312. {***SETCONST}
  1313. {constset:;} {*** I don't know what to do with a set.}
  1314. { sets are not recognized by GDB}
  1315. {***}
  1316. end;
  1317. stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
  1318. tostr(fileinfo.line)+',0');
  1319. end;
  1320. procedure tconstsym.concatstabto(asmlist : paasmoutput);
  1321. begin
  1322. if consttype <> conststring then
  1323. inherited concatstabto(asmlist);
  1324. end;
  1325. {$endif GDB}
  1326. {****************************************************************************
  1327. TENUMSYM
  1328. ****************************************************************************}
  1329. constructor tenumsym.init(const n : string;def : penumdef;v : longint);
  1330. begin
  1331. tsym.init(n);
  1332. typ:=enumsym;
  1333. definition:=def;
  1334. value:=v;
  1335. if def^.min>v then
  1336. def^.setmin(v);
  1337. if def^.max<v then
  1338. def^.setmax(v);
  1339. order;
  1340. end;
  1341. constructor tenumsym.load;
  1342. begin
  1343. tsym.load;
  1344. typ:=enumsym;
  1345. definition:=penumdef(readdefref);
  1346. value:=readlong;
  1347. next := Nil;
  1348. end;
  1349. procedure tenumsym.deref;
  1350. begin
  1351. resolvedef(pdef(definition));
  1352. order;
  1353. end;
  1354. procedure tenumsym.order;
  1355. var
  1356. sym : penumsym;
  1357. begin
  1358. sym := definition^.first;
  1359. if sym = nil then
  1360. begin
  1361. definition^.first := @self;
  1362. next := nil;
  1363. exit;
  1364. end;
  1365. { reorder the symbols in increasing value }
  1366. if value < sym^.value then
  1367. begin
  1368. next := sym;
  1369. definition^.first := @self;
  1370. end
  1371. else
  1372. begin
  1373. while (sym^.value <= value) and assigned(sym^.next) do
  1374. sym := sym^.next;
  1375. next := sym^.next;
  1376. sym^.next := @self;
  1377. end;
  1378. end;
  1379. procedure tenumsym.write;
  1380. begin
  1381. tsym.write;
  1382. writedefref(definition);
  1383. writelong(value);
  1384. current_ppu^.writeentry(ibenumsym);
  1385. end;
  1386. {$ifdef GDB}
  1387. procedure tenumsym.concatstabto(asmlist : paasmoutput);
  1388. begin
  1389. {enum elements have no stab !}
  1390. end;
  1391. {$EndIf GDB}
  1392. {****************************************************************************
  1393. TTYPESYM
  1394. ****************************************************************************}
  1395. constructor ttypesym.init(const n : string;d : pdef);
  1396. begin
  1397. tsym.init(n);
  1398. typ:=typesym;
  1399. definition:=d;
  1400. {$ifdef GDB}
  1401. isusedinstab := false;
  1402. {$endif GDB}
  1403. forwardpointer:=nil;
  1404. { this allows to link definitions with the type with declares }
  1405. { them }
  1406. if assigned(definition) then
  1407. if definition^.sym=nil then
  1408. definition^.sym:=@self;
  1409. end;
  1410. constructor ttypesym.load;
  1411. begin
  1412. tsym.load;
  1413. typ:=typesym;
  1414. forwardpointer:=nil;
  1415. {$ifdef GDB}
  1416. isusedinstab := false;
  1417. {$endif GDB}
  1418. definition:=readdefref;
  1419. end;
  1420. destructor ttypesym.done;
  1421. begin
  1422. if assigned(definition) then
  1423. if definition^.sym=@self then
  1424. definition^.sym:=nil;
  1425. inherited done;
  1426. end;
  1427. procedure ttypesym.deref;
  1428. begin
  1429. resolvedef(definition);
  1430. if assigned(definition) then
  1431. begin
  1432. if definition^.sym=nil then
  1433. definition^.sym:=@self;
  1434. if (definition^.deftype=recorddef) and assigned(precdef(definition)^.symtable) and
  1435. (definition^.sym=@self) then
  1436. precdef(definition)^.symtable^.name:=stringdup('record '+name);
  1437. end;
  1438. end;
  1439. procedure ttypesym.write;
  1440. begin
  1441. tsym.write;
  1442. writedefref(definition);
  1443. current_ppu^.writeentry(ibtypesym);
  1444. end;
  1445. {$ifdef UseBrowser}
  1446. procedure ttypesym.load_references;
  1447. begin
  1448. inherited load_references;
  1449. if (definition^.deftype=recorddef) then
  1450. precdef(definition)^.symtable^.load_browser;
  1451. if (definition^.deftype=objectdef) then
  1452. pobjectdef(definition)^.publicsyms^.load_browser;
  1453. end;
  1454. function ttypesym.write_references : boolean;
  1455. begin
  1456. if not inherited write_references then
  1457. { write address of this symbol if record or object
  1458. even if no real refs are there
  1459. because we need it for the symtable }
  1460. if (definition^.deftype=recorddef) or
  1461. (definition^.deftype=objectdef) then
  1462. begin
  1463. writesymref(@self);
  1464. current_ppu^.writeentry(ibsymref);
  1465. end;
  1466. write_references:=true;
  1467. if (definition^.deftype=recorddef) then
  1468. precdef(definition)^.symtable^.write_browser;
  1469. if (definition^.deftype=objectdef) then
  1470. pobjectdef(definition)^.publicsyms^.write_browser;
  1471. end;
  1472. procedure ttypesym.add_to_browserlog;
  1473. begin
  1474. inherited add_to_browserlog;
  1475. if (definition^.deftype=recorddef) then
  1476. precdef(definition)^.symtable^.writebrowserlog;
  1477. if (definition^.deftype=objectdef) then
  1478. pobjectdef(definition)^.publicsyms^.writebrowserlog;
  1479. end;
  1480. {$endif UseBrowser}
  1481. {$ifdef GDB}
  1482. function ttypesym.stabstring : pchar;
  1483. var stabchar : string[2];
  1484. short : string;
  1485. begin
  1486. if definition^.deftype in tagtypes then
  1487. stabchar := 'Tt'
  1488. else
  1489. stabchar := 't';
  1490. short := '"'+name+':'+stabchar+definition^.numberstring
  1491. +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
  1492. stabstring := strpnew(short);
  1493. end;
  1494. procedure ttypesym.concatstabto(asmlist : paasmoutput);
  1495. begin
  1496. {not stabs for forward defs }
  1497. if assigned(definition) then
  1498. if (definition^.sym = @self) then
  1499. definition^.concatstabto(asmlist)
  1500. else
  1501. inherited concatstabto(asmlist);
  1502. end;
  1503. {$endif GDB}
  1504. {****************************************************************************
  1505. TSYSSYM
  1506. ****************************************************************************}
  1507. constructor tsyssym.init(const n : string;l : longint);
  1508. begin
  1509. inherited init(n);
  1510. typ:=syssym;
  1511. number:=l;
  1512. end;
  1513. procedure tsyssym.write;
  1514. begin
  1515. end;
  1516. {$ifdef GDB}
  1517. procedure tsyssym.concatstabto(asmlist : paasmoutput);
  1518. begin
  1519. end;
  1520. {$endif GDB}
  1521. {****************************************************************************
  1522. TMACROSYM
  1523. ****************************************************************************}
  1524. constructor tmacrosym.init(const n : string);
  1525. begin
  1526. inherited init(n);
  1527. typ:=macrosym;
  1528. defined:=true;
  1529. buftext:=nil;
  1530. buflen:=0;
  1531. end;
  1532. destructor tmacrosym.done;
  1533. begin
  1534. if assigned(buftext) then
  1535. freemem(buftext,buflen);
  1536. inherited done;
  1537. end;
  1538. {
  1539. $Log$
  1540. Revision 1.67 1998-12-30 22:15:54 peter
  1541. + farpointer type
  1542. * absolutesym now also stores if its far
  1543. Revision 1.66 1998/12/30 13:41:14 peter
  1544. * released valuepara
  1545. Revision 1.65 1998/12/26 15:35:44 peter
  1546. + read/write of constnil
  1547. Revision 1.64 1998/12/08 10:18:15 peter
  1548. + -gh for heaptrc unit
  1549. Revision 1.63 1998/11/28 16:20:56 peter
  1550. + support for dll variables
  1551. Revision 1.62 1998/11/27 14:50:48 peter
  1552. + open strings, $P switch support
  1553. Revision 1.61 1998/11/18 15:44:18 peter
  1554. * VALUEPARA for tp7 compatible value parameters
  1555. Revision 1.60 1998/11/16 10:13:51 peter
  1556. * label defines are checked at the end of the proc
  1557. Revision 1.59 1998/11/13 12:09:11 peter
  1558. * unused label is now a warning
  1559. Revision 1.58 1998/11/10 10:50:57 pierre
  1560. * temporary fix for long mangled procsym names
  1561. Revision 1.57 1998/11/05 23:39:31 peter
  1562. + typedconst.getsize
  1563. Revision 1.56 1998/10/28 18:26:18 pierre
  1564. * removed some erros after other errors (introduced by useexcept)
  1565. * stabs works again correctly (for how long !)
  1566. Revision 1.55 1998/10/20 08:07:00 pierre
  1567. * several memory corruptions due to double freemem solved
  1568. => never use p^.loc.location:=p^.left^.loc.location;
  1569. + finally I added now by default
  1570. that ra386dir translates global and unit symbols
  1571. + added a first field in tsymtable and
  1572. a nextsym field in tsym
  1573. (this allows to obtain ordered type info for
  1574. records and objects in gdb !)
  1575. Revision 1.54 1998/10/19 08:55:07 pierre
  1576. * wrong stabs info corrected once again !!
  1577. + variable vmt offset with vmt field only if required
  1578. implemented now !!!
  1579. Revision 1.53 1998/10/16 08:51:53 peter
  1580. + target_os.stackalignment
  1581. + stack can be aligned at 2 or 4 byte boundaries
  1582. Revision 1.52 1998/10/08 17:17:32 pierre
  1583. * current_module old scanner tagged as invalid if unit is recompiled
  1584. + added ppheap for better info on tracegetmem of heaptrc
  1585. (adds line column and file index)
  1586. * several memory leaks removed ith help of heaptrc !!
  1587. Revision 1.51 1998/10/08 13:48:50 peter
  1588. * fixed memory leaks for do nothing source
  1589. * fixed unit interdependency
  1590. Revision 1.50 1998/10/06 17:16:56 pierre
  1591. * some memory leaks fixed (thanks to Peter for heaptrc !)
  1592. Revision 1.49 1998/10/01 09:22:55 peter
  1593. * fixed value openarray
  1594. * ungettemp of arrayconstruct
  1595. Revision 1.48 1998/09/26 17:45:44 peter
  1596. + idtoken and only one token table
  1597. Revision 1.47 1998/09/24 15:11:17 peter
  1598. * fixed enum for not GDB
  1599. Revision 1.46 1998/09/23 15:39:13 pierre
  1600. * browser bugfixes
  1601. was adding a reference when looking for the symbol
  1602. if -bSYM_NAME was used
  1603. Revision 1.45 1998/09/21 08:45:24 pierre
  1604. + added vmt_offset in tobjectdef.write for fututre use
  1605. (first steps to have objects without vmt if no virtual !!)
  1606. + added fpu_used field for tabstractprocdef :
  1607. sets this level to 2 if the functions return with value in FPU
  1608. (is then set to correct value at parsing of implementation)
  1609. THIS MIGHT refuse some code with FPU expression too complex
  1610. that were accepted before and even in some cases
  1611. that don't overflow in fact
  1612. ( like if f : float; is a forward that finally in implementation
  1613. only uses one fpu register !!)
  1614. Nevertheless I think that it will improve security on
  1615. FPU operations !!
  1616. * most other changes only for UseBrowser code
  1617. (added symtable references for record and objects)
  1618. local switch for refs to args and local of each function
  1619. (static symtable still missing)
  1620. UseBrowser still not stable and probably broken by
  1621. the definition hash array !!
  1622. Revision 1.44 1998/09/18 16:03:47 florian
  1623. * some changes to compile with Delphi
  1624. Revision 1.43 1998/09/18 08:01:38 pierre
  1625. + improvement on the usebrowser part
  1626. (does not work correctly for now)
  1627. Revision 1.42 1998/09/07 19:33:25 florian
  1628. + some stuff for property rtti added:
  1629. - NameIndex of the TPropInfo record is now written correctly
  1630. - the DEFAULT/NODEFAULT keyword is supported now
  1631. - the default value and the storedsym/def are now written to
  1632. the PPU fiel
  1633. Revision 1.41 1998/09/07 18:46:12 peter
  1634. * update smartlinking, uses getdatalabel
  1635. * renamed ptree.value vars to value_str,value_real,value_set
  1636. Revision 1.40 1998/09/07 17:37:04 florian
  1637. * first fixes for published properties
  1638. Revision 1.39 1998/09/05 22:11:02 florian
  1639. + switch -vb
  1640. * while/repeat loops accept now also word/longbool conditions
  1641. * makebooltojump did an invalid ungetregister32, fixed
  1642. Revision 1.38 1998/09/01 12:53:26 peter
  1643. + aktpackenum
  1644. Revision 1.37 1998/09/01 07:54:25 pierre
  1645. * UseBrowser a little updated (might still be buggy !!)
  1646. * bug in psub.pas in function specifier removed
  1647. * stdcall allowed in interface and in implementation
  1648. (FPC will not yet complain if it is missing in either part
  1649. because stdcall is only a dummy !!)
  1650. Revision 1.36 1998/08/25 13:09:26 pierre
  1651. * corrected mangling sheme :
  1652. cvar add Cprefix to the mixed case name whereas
  1653. export or public use direct name
  1654. Revision 1.35 1998/08/25 12:42:46 pierre
  1655. * CDECL changed to CVAR for variables
  1656. specifications are read in structures also
  1657. + started adding GPC compatibility mode ( option -Sp)
  1658. * names changed to lowercase
  1659. Revision 1.34 1998/08/21 14:08:53 pierre
  1660. + TEST_FUNCRET now default (old code removed)
  1661. works also for m68k (at least compiles)
  1662. Revision 1.33 1998/08/20 12:53:27 peter
  1663. * object_options are always written for object syms
  1664. Revision 1.32 1998/08/20 09:26:46 pierre
  1665. + funcret setting in underproc testing
  1666. compile with _dTEST_FUNCRET
  1667. Revision 1.31 1998/08/17 10:10:12 peter
  1668. - removed OLDPPU
  1669. Revision 1.30 1998/08/13 10:57:29 peter
  1670. * constant sets are now written correctly to the ppufile
  1671. Revision 1.29 1998/08/11 15:31:42 peter
  1672. * write extended to ppu file
  1673. * new version 0.99.7
  1674. Revision 1.28 1998/08/11 14:07:27 peter
  1675. * fixed pushing of high value for openarray
  1676. Revision 1.27 1998/08/10 14:50:31 peter
  1677. + localswitches, moduleswitches, globalswitches splitting
  1678. Revision 1.26 1998/08/10 10:18:35 peter
  1679. + Compiler,Comphook unit which are the new interface units to the
  1680. compiler
  1681. Revision 1.25 1998/07/30 11:18:19 florian
  1682. + first implementation of try ... except on .. do end;
  1683. * limitiation of 65535 bytes parameters for cdecl removed
  1684. Revision 1.24 1998/07/20 18:40:16 florian
  1685. * handling of ansi string constants should now work
  1686. Revision 1.23 1998/07/14 21:37:24 peter
  1687. * fixed packrecords as discussed at the alias
  1688. Revision 1.22 1998/07/14 14:47:08 peter
  1689. * released NEWINPUT
  1690. Revision 1.21 1998/07/13 21:17:38 florian
  1691. * changed to compile with TP
  1692. Revision 1.20 1998/07/10 00:00:05 peter
  1693. * fixed ttypesym bug finally
  1694. * fileinfo in the symtable and better using for unused vars
  1695. Revision 1.19 1998/07/07 17:40:39 peter
  1696. * packrecords 4 works
  1697. * word aligning of parameters
  1698. Revision 1.18 1998/07/07 11:20:15 peter
  1699. + NEWINPUT for a better inputfile and scanner object
  1700. Revision 1.17 1998/06/24 14:48:40 peter
  1701. * ifdef newppu -> ifndef oldppu
  1702. Revision 1.16 1998/06/19 15:40:42 peter
  1703. * removed cosntructor/constructor warning and 0.99.5 recompiles it again
  1704. Revision 1.15 1998/06/17 14:10:18 peter
  1705. * small os2 fixes
  1706. * fixed interdependent units with newppu (remake3 under linux works now)
  1707. Revision 1.14 1998/06/16 08:56:34 peter
  1708. + targetcpu
  1709. * cleaner pmodules for newppu
  1710. Revision 1.13 1998/06/15 15:38:10 pierre
  1711. * small bug in systems.pas corrected
  1712. + operators in different units better hanlded
  1713. Revision 1.12 1998/06/15 14:23:44 daniel
  1714. * Reverted my changes.
  1715. Revision 1.10 1998/06/13 00:10:18 peter
  1716. * working browser and newppu
  1717. * some small fixes against crashes which occured in bp7 (but not in
  1718. fpc?!)
  1719. Revision 1.9 1998/06/12 16:15:35 pierre
  1720. * external name 'C_var';
  1721. export name 'intern_C_var';
  1722. cdecl;
  1723. cdecl;external;
  1724. are now supported only with -Sv switch
  1725. Revision 1.8 1998/06/11 10:11:59 peter
  1726. * -gb works again
  1727. Revision 1.7 1998/06/09 16:01:51 pierre
  1728. + added procedure directive parsing for procvars
  1729. (accepted are popstack cdecl and pascal)
  1730. + added C vars with the following syntax
  1731. var C calias 'true_c_name';(can be followed by external)
  1732. reason is that you must add the Cprefix
  1733. which is target dependent
  1734. Revision 1.6 1998/06/08 22:59:53 peter
  1735. * smartlinking works for win32
  1736. * some defines to exclude some compiler parts
  1737. Revision 1.5 1998/06/04 23:52:02 peter
  1738. * m68k compiles
  1739. + .def file creation moved to gendef.pas so it could also be used
  1740. for win32
  1741. Revision 1.4 1998/06/04 09:55:46 pierre
  1742. * demangled name of procsym reworked to become independant of the mangling scheme
  1743. Revision 1.3 1998/06/03 22:14:20 florian
  1744. * problem with sizes of classes fixed (if the anchestor was declared
  1745. forward, the compiler doesn't update the child classes size)
  1746. Revision 1.2 1998/05/28 14:40:29 peter
  1747. * fixes for newppu, remake3 works now with it
  1748. Revision 1.1 1998/05/27 19:45:09 peter
  1749. * symtable.pas splitted into includefiles
  1750. * symtable adapted for $ifndef OLDPPU
  1751. }