symsym.inc 60 KB

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