symsym.inc 60 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043
  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. refs:=0;
  725. is_valid := 1;
  726. var_options:=0;
  727. { can we load the value into a register ? }
  728. case p^.deftype of
  729. pointerdef,
  730. enumdef,
  731. procvardef : var_options:=var_options or vo_regable;
  732. orddef : case porddef(p)^.typ of
  733. u8bit,u16bit,u32bit,
  734. bool8bit,bool16bit,bool32bit,
  735. s8bit,s16bit,s32bit :
  736. var_options:=var_options or vo_regable;
  737. else
  738. var_options:=var_options and not vo_regable;
  739. end;
  740. else
  741. var_options:=var_options and not vo_regable;
  742. end;
  743. reg:=R_NO;
  744. end;
  745. constructor tvarsym.init_dll(const n : string;p : pdef);
  746. begin
  747. { The tvarsym is necessary for 0.99.5 (PFV) }
  748. tvarsym.init(n,p);
  749. var_options:=var_options or vo_is_dll_var;
  750. end;
  751. constructor tvarsym.init_C(const n,mangled : 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_C_var;
  756. setmangledname(mangled);
  757. end;
  758. constructor tvarsym.load;
  759. begin
  760. tsym.load;
  761. typ:=varsym;
  762. _mangledname:=nil;
  763. reg:=R_NO;
  764. refs := 0;
  765. is_valid := 1;
  766. varspez:=tvarspez(readbyte);
  767. if read_member then
  768. address:=readlong
  769. else
  770. address:=0;
  771. localaddress:=-1;
  772. islocalcopy:=false;
  773. definition:=readdefref;
  774. var_options:=readbyte;
  775. if (var_options and vo_is_C_var)<>0 then
  776. setmangledname(readstring);
  777. end;
  778. procedure tvarsym.deref;
  779. begin
  780. resolvedef(definition);
  781. end;
  782. procedure tvarsym.write;
  783. begin
  784. tsym.write;
  785. writebyte(byte(varspez));
  786. if read_member then
  787. writelong(address);
  788. writedefref(definition);
  789. { symbols which are load are never candidates for a register,
  790. turn of the regable }
  791. writebyte(var_options and (not vo_regable));
  792. if (var_options and vo_is_C_var)<>0 then
  793. writestring(mangledname);
  794. current_ppu^.writeentry(ibvarsym);
  795. end;
  796. procedure tvarsym.setmangledname(const s : string);
  797. begin
  798. _mangledname:=strpnew(s);
  799. end;
  800. function tvarsym.mangledname : string;
  801. var
  802. prefix : string;
  803. begin
  804. if assigned(_mangledname) then
  805. begin
  806. mangledname:=strpas(_mangledname);
  807. exit;
  808. end;
  809. case owner^.symtabletype of
  810. staticsymtable : if (cs_smartlink in aktmoduleswitches) then
  811. prefix:='_'+owner^.name^+'$$$_'
  812. else
  813. prefix:='_';
  814. unitsymtable,
  815. globalsymtable : prefix:='U_'+owner^.name^+'_';
  816. else
  817. Message(sym_e_invalid_call_tvarsymmangledname);
  818. end;
  819. mangledname:=prefix+name;
  820. end;
  821. function tvarsym.getsize : longint;
  822. begin
  823. if assigned(definition) and (varspez=vs_value) then
  824. getsize:=definition^.size
  825. else
  826. getsize:=0;
  827. end;
  828. function tvarsym.getpushsize : longint;
  829. begin
  830. if assigned(definition) then
  831. begin
  832. case varspez of
  833. vs_var :
  834. begin
  835. { open arrays push also the high valye }
  836. if is_open_array(definition) or
  837. is_open_string(definition) then
  838. getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
  839. else
  840. getpushsize:=target_os.size_of_pointer;
  841. end;
  842. vs_value,
  843. vs_const :
  844. begin
  845. case definition^.deftype of
  846. setdef,
  847. stringdef,
  848. recorddef,
  849. objectdef :
  850. getpushsize:=target_os.size_of_pointer;
  851. arraydef :
  852. if is_open_array(definition) then
  853. getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
  854. else
  855. getpushsize:=target_os.size_of_pointer;
  856. else
  857. getpushsize:=definition^.size;
  858. end;
  859. end;
  860. end;
  861. end
  862. else
  863. getpushsize:=0;
  864. end;
  865. procedure tvarsym.insert_in_data;
  866. var
  867. l,modulo : longint;
  868. begin
  869. if (var_options and vo_is_external)<>0 then
  870. exit;
  871. { handle static variables of objects especially }
  872. if read_member and (owner^.symtabletype=objectsymtable) and
  873. ((properties and sp_static)<>0) then
  874. begin
  875. { the data filed is generated in parser.pas
  876. with a tobject_FIELDNAME variable }
  877. { this symbol can't be loaded to a register }
  878. var_options:=var_options and not vo_regable;
  879. end
  880. else
  881. if not(read_member) then
  882. begin
  883. { made problems with parameters etc. ! (FK) }
  884. { check for instance of an abstract object or class }
  885. {
  886. if (pvarsym(sym)^.definition^.deftype=objectdef) and
  887. ((pobjectdef(pvarsym(sym)^.definition)^.options and oo_is_abstract)<>0) then
  888. Message(sym_e_no_instance_of_abstract_object);
  889. }
  890. l:=getsize;
  891. case owner^.symtabletype of
  892. stt_exceptsymtable:
  893. { can contain only one symbol, address calculated later }
  894. ;
  895. localsymtable :
  896. begin
  897. is_valid := 0;
  898. modulo:=owner^.datasize and 3;
  899. {$ifdef m68k}
  900. { word alignment required for motorola }
  901. if (l=1) then
  902. l:=2
  903. else
  904. {$endif}
  905. if (l>=4) and (modulo<>0) then
  906. inc(l,4-modulo)
  907. else
  908. if (l>=2) and ((modulo and 1)<>0) then
  909. inc(l,2-(modulo and 1));
  910. inc(owner^.datasize,l);
  911. address:=owner^.datasize;
  912. end;
  913. staticsymtable :
  914. begin
  915. if (cs_smartlink in aktmoduleswitches) then
  916. bsssegment^.concat(new(pai_cut,init));
  917. {$ifdef GDB}
  918. if cs_debuginfo in aktmoduleswitches then
  919. concatstabto(bsssegment);
  920. {$endif GDB}
  921. if (cs_smartlink in aktmoduleswitches) or
  922. ((var_options and vo_is_c_var)<>0) then
  923. bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)))
  924. else
  925. bsssegment^.concat(new(pai_datablock,init(mangledname,l)));
  926. { increase datasize }
  927. inc(owner^.datasize,l);
  928. { this symbol can't be loaded to a register }
  929. var_options:=var_options and not vo_regable;
  930. end;
  931. globalsymtable :
  932. begin
  933. if (cs_smartlink in aktmoduleswitches) then
  934. bsssegment^.concat(new(pai_cut,init));
  935. {$ifdef GDB}
  936. if cs_debuginfo in aktmoduleswitches then
  937. concatstabto(bsssegment);
  938. {$endif GDB}
  939. bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)));
  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. recordsymtable,
  945. objectsymtable :
  946. begin
  947. { this symbol can't be loaded to a register }
  948. var_options:=var_options and not vo_regable;
  949. { align record and object fields }
  950. if (l=1) or (aktpackrecords=1) then
  951. begin
  952. address:=owner^.datasize;
  953. inc(owner^.datasize,l)
  954. end
  955. else
  956. if (l=2) or (aktpackrecords=2) then
  957. begin
  958. owner^.datasize:=(owner^.datasize+1) and (not 1);
  959. address:=owner^.datasize;
  960. inc(owner^.datasize,l)
  961. end
  962. else
  963. if (l<=4) or (aktpackrecords=4) then
  964. begin
  965. owner^.datasize:=(owner^.datasize+3) and (not 3);
  966. address:=owner^.datasize;
  967. inc(owner^.datasize,l);
  968. end
  969. else
  970. if (l<=8) or (aktpackrecords=8) then
  971. begin
  972. owner^.datasize:=(owner^.datasize+7) and (not 7);
  973. address:=owner^.datasize;
  974. inc(owner^.datasize,l);
  975. end
  976. else
  977. if (l<=16) or (aktpackrecords=16) then
  978. begin
  979. owner^.datasize:=(owner^.datasize+15) and (not 15);
  980. address:=owner^.datasize;
  981. inc(owner^.datasize,l);
  982. end
  983. else
  984. if (l<=32) or (aktpackrecords=32) then
  985. begin
  986. owner^.datasize:=(owner^.datasize+31) and (not 31);
  987. address:=owner^.datasize;
  988. inc(owner^.datasize,l);
  989. end;
  990. end;
  991. parasymtable :
  992. begin
  993. { here we need the size of a push instead of the
  994. size of the data }
  995. l:=getpushsize;
  996. address:=owner^.datasize;
  997. owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment);
  998. end
  999. else
  1000. begin
  1001. modulo:=owner^.datasize and 3 ;
  1002. if (l>=4) and (modulo<>0) then
  1003. inc(owner^.datasize,4-modulo)
  1004. else
  1005. if (l>=2) and ((modulo and 1)<>0) then
  1006. inc(owner^.datasize);
  1007. address:=owner^.datasize;
  1008. inc(owner^.datasize,l);
  1009. end;
  1010. end;
  1011. end;
  1012. end;
  1013. {$ifdef GDB}
  1014. function tvarsym.stabstring : pchar;
  1015. var
  1016. st : char;
  1017. begin
  1018. if (owner^.symtabletype = objectsymtable) and
  1019. ((properties and sp_static)<>0) then
  1020. begin
  1021. if (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S';
  1022. stabstring := strpnew('"'+owner^.name^+'__'+name+':'+
  1023. +definition^.numberstring+'",'+
  1024. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1025. end
  1026. else if (owner^.symtabletype = globalsymtable) or
  1027. (owner^.symtabletype = unitsymtable) then
  1028. begin
  1029. { Here we used S instead of
  1030. because with G GDB doesn't look at the address field
  1031. but searches the same name or with a leading underscore
  1032. but these names don't exist in pascal !}
  1033. if (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S';
  1034. stabstring := strpnew('"'+name+':'+st
  1035. +definition^.numberstring+'",'+
  1036. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1037. end
  1038. else if owner^.symtabletype = staticsymtable then
  1039. begin
  1040. stabstring := strpnew('"'+name+':S'
  1041. +definition^.numberstring+'",'+
  1042. tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
  1043. end
  1044. else if (owner^.symtabletype=parasymtable) then
  1045. begin
  1046. case varspez of
  1047. vs_var : st := 'v';
  1048. vs_value,
  1049. vs_const : if push_addr_param(definition) then
  1050. st := 'v' { should be 'i' but 'i' doesn't work }
  1051. else
  1052. st := 'p';
  1053. end;
  1054. stabstring := strpnew('"'+name+':'+st
  1055. +definition^.numberstring+'",'+
  1056. tostr(N_PSYM)+',0,'+tostr(fileinfo.line)+','+
  1057. tostr(address+owner^.call_offset));
  1058. {offset to ebp => will not work if the framepointer is esp
  1059. so some optimizing will make things harder to debug }
  1060. end
  1061. else if (owner^.symtabletype=localsymtable) then
  1062. {$ifdef i386}
  1063. if reg<>R_NO then
  1064. begin
  1065. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1066. { this is the register order for GDB}
  1067. stabstring:=strpnew('"'+name+':r'
  1068. +definition^.numberstring+'",'+
  1069. tostr(N_RSYM)+',0,'+
  1070. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1071. end
  1072. else
  1073. {$endif i386}
  1074. stabstring := strpnew('"'+name+':'
  1075. +definition^.numberstring+'",'+
  1076. tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address))
  1077. else
  1078. stabstring := inherited stabstring;
  1079. end;
  1080. procedure tvarsym.concatstabto(asmlist : paasmoutput);
  1081. {$ifdef i386}
  1082. var stab_str : pchar;
  1083. {$endif i386}
  1084. begin
  1085. inherited concatstabto(asmlist);
  1086. {$ifdef i386}
  1087. if (owner^.symtabletype=parasymtable) and
  1088. (reg<>R_NO) then
  1089. begin
  1090. { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
  1091. { this is the register order for GDB}
  1092. stab_str:=strpnew('"'+name+':r'
  1093. +definition^.numberstring+'",'+
  1094. tostr(N_RSYM)+',0,'+
  1095. tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
  1096. asmlist^.concat(new(pai_stabs,init(stab_str)));
  1097. end;
  1098. {$endif i386}
  1099. end;
  1100. {$endif GDB}
  1101. destructor tvarsym.done;
  1102. begin
  1103. strdispose(_mangledname);
  1104. inherited done;
  1105. end;
  1106. {****************************************************************************
  1107. TTYPEDCONSTSYM
  1108. *****************************************************************************}
  1109. constructor ttypedconstsym.init(const n : string;p : pdef);
  1110. begin
  1111. tsym.init(n);
  1112. typ:=typedconstsym;
  1113. definition:=p;
  1114. prefix:=stringdup(procprefix);
  1115. end;
  1116. constructor ttypedconstsym.load;
  1117. begin
  1118. tsym.load;
  1119. typ:=typedconstsym;
  1120. definition:=readdefref;
  1121. prefix:=stringdup(readstring);
  1122. end;
  1123. destructor ttypedconstsym.done;
  1124. begin
  1125. stringdispose(prefix);
  1126. tsym.done;
  1127. end;
  1128. function ttypedconstsym.mangledname : string;
  1129. begin
  1130. mangledname:='TC_'+prefix^+'_'+name;
  1131. end;
  1132. function ttypedconstsym.getsize : longint;
  1133. begin
  1134. if assigned(definition) then
  1135. getsize:=definition^.size
  1136. else
  1137. getsize:=0;
  1138. end;
  1139. procedure ttypedconstsym.deref;
  1140. begin
  1141. resolvedef(definition);
  1142. end;
  1143. procedure ttypedconstsym.write;
  1144. begin
  1145. tsym.write;
  1146. writedefref(definition);
  1147. writestring(prefix^);
  1148. current_ppu^.writeentry(ibtypedconstsym);
  1149. end;
  1150. { for most symbol types ther is nothing to do at all }
  1151. procedure ttypedconstsym.insert_in_data;
  1152. begin
  1153. { here there is a problem for ansistrings !! }
  1154. { we must write the label only after the 12 header bytes (PM)
  1155. if not is_ansistring(definition) then
  1156. }
  1157. { solved, the ansis string is moved to consts (FK) }
  1158. really_insert_in_data;
  1159. end;
  1160. procedure ttypedconstsym.really_insert_in_data;
  1161. begin
  1162. if owner^.symtabletype=globalsymtable then
  1163. begin
  1164. if (cs_smartlink in aktmoduleswitches) then
  1165. datasegment^.concat(new(pai_cut,init));
  1166. {$ifdef GDB}
  1167. if cs_debuginfo in aktmoduleswitches then
  1168. concatstabto(datasegment);
  1169. {$endif GDB}
  1170. datasegment^.concat(new(pai_symbol,init_global(mangledname)));
  1171. end
  1172. else
  1173. if owner^.symtabletype<>unitsymtable then
  1174. begin
  1175. if (cs_smartlink in aktmoduleswitches) then
  1176. datasegment^.concat(new(pai_cut,init));
  1177. {$ifdef GDB}
  1178. if cs_debuginfo in aktmoduleswitches then
  1179. concatstabto(datasegment);
  1180. {$endif GDB}
  1181. if (cs_smartlink in aktmoduleswitches) then
  1182. datasegment^.concat(new(pai_symbol,init_global(mangledname)))
  1183. else
  1184. datasegment^.concat(new(pai_symbol,init(mangledname)));
  1185. end;
  1186. end;
  1187. {$ifdef GDB}
  1188. function ttypedconstsym.stabstring : pchar;
  1189. var
  1190. st : char;
  1191. begin
  1192. if (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then
  1193. st := 'G'
  1194. else
  1195. st := 'S';
  1196. stabstring := strpnew('"'+name+':'+st+
  1197. definition^.numberstring+'",'+tostr(n_STSYM)+',0,'+
  1198. tostr(fileinfo.line)+','+mangledname);
  1199. end;
  1200. {$endif GDB}
  1201. {****************************************************************************
  1202. TCONSTSYM
  1203. ****************************************************************************}
  1204. constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);
  1205. begin
  1206. tsym.init(n);
  1207. typ:=constsym;
  1208. definition:=def;
  1209. consttype:=t;
  1210. value:=v;
  1211. end;
  1212. constructor tconstsym.load;
  1213. var
  1214. pd : pbestreal;
  1215. ps : pnormalset;
  1216. begin
  1217. tsym.load;
  1218. typ:=constsym;
  1219. consttype:=tconsttype(readbyte);
  1220. case consttype of
  1221. constint,
  1222. constbool,
  1223. constchar : value:=readlong;
  1224. constord : begin
  1225. definition:=readdefref;
  1226. value:=readlong;
  1227. end;
  1228. conststring : value:=longint(stringdup(readstring));
  1229. constreal : begin
  1230. new(pd);
  1231. pd^:=readreal;
  1232. value:=longint(pd);
  1233. end;
  1234. constset : begin
  1235. definition:=readdefref;
  1236. new(ps);
  1237. readnormalset(ps^);
  1238. value:=longint(ps);
  1239. end;
  1240. constnil : ;
  1241. else
  1242. Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
  1243. end;
  1244. end;
  1245. destructor tconstsym.done;
  1246. begin
  1247. case consttype of
  1248. conststring : stringdispose(pstring(value));
  1249. constreal : dispose(pbestreal(value));
  1250. constset : dispose(pnormalset(value));
  1251. end;
  1252. inherited done;
  1253. end;
  1254. function tconstsym.mangledname : string;
  1255. begin
  1256. mangledname:=name;
  1257. end;
  1258. procedure tconstsym.deref;
  1259. begin
  1260. if consttype in [constord,constset] then
  1261. resolvedef(pdef(definition));
  1262. end;
  1263. procedure tconstsym.write;
  1264. begin
  1265. tsym.write;
  1266. writebyte(byte(consttype));
  1267. case consttype of
  1268. constnil : ;
  1269. constint,
  1270. constbool,
  1271. constchar : writelong(value);
  1272. constord : begin
  1273. writedefref(definition);
  1274. writelong(value);
  1275. end;
  1276. conststring : writestring(pstring(value)^);
  1277. constreal : writereal(pbestreal(value)^);
  1278. constset : begin
  1279. writedefref(definition);
  1280. writenormalset(pointer(value)^);
  1281. end;
  1282. else
  1283. internalerror(13);
  1284. end;
  1285. current_ppu^.writeentry(ibconstsym);
  1286. end;
  1287. {$ifdef GDB}
  1288. function tconstsym.stabstring : pchar;
  1289. var st : string;
  1290. begin
  1291. {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
  1292. case consttype of
  1293. conststring : begin
  1294. { I had to remove ibm2ascii !! }
  1295. st := pstring(value)^;
  1296. {st := ibm2ascii(pstring(value)^);}
  1297. st := 's'''+st+'''';
  1298. end;
  1299. constbool, constint, constord, constchar : st := 'i'+tostr(value);
  1300. constreal : begin
  1301. system.str(pbestreal(value)^,st);
  1302. st := 'r'+st;
  1303. end;
  1304. { if we don't know just put zero !! }
  1305. else st:='i0';
  1306. {***SETCONST}
  1307. {constset:;} {*** I don't know what to do with a set.}
  1308. { sets are not recognized by GDB}
  1309. {***}
  1310. end;
  1311. stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
  1312. tostr(fileinfo.line)+',0');
  1313. end;
  1314. procedure tconstsym.concatstabto(asmlist : paasmoutput);
  1315. begin
  1316. if consttype <> conststring then
  1317. inherited concatstabto(asmlist);
  1318. end;
  1319. {$endif GDB}
  1320. {****************************************************************************
  1321. TENUMSYM
  1322. ****************************************************************************}
  1323. constructor tenumsym.init(const n : string;def : penumdef;v : longint);
  1324. begin
  1325. tsym.init(n);
  1326. typ:=enumsym;
  1327. definition:=def;
  1328. value:=v;
  1329. if def^.min>v then
  1330. def^.setmin(v);
  1331. if def^.max<v then
  1332. def^.setmax(v);
  1333. order;
  1334. end;
  1335. constructor tenumsym.load;
  1336. begin
  1337. tsym.load;
  1338. typ:=enumsym;
  1339. definition:=penumdef(readdefref);
  1340. value:=readlong;
  1341. next := Nil;
  1342. end;
  1343. procedure tenumsym.deref;
  1344. begin
  1345. resolvedef(pdef(definition));
  1346. order;
  1347. end;
  1348. procedure tenumsym.order;
  1349. var
  1350. sym : penumsym;
  1351. begin
  1352. sym := definition^.first;
  1353. if sym = nil then
  1354. begin
  1355. definition^.first := @self;
  1356. next := nil;
  1357. exit;
  1358. end;
  1359. { reorder the symbols in increasing value }
  1360. if value < sym^.value then
  1361. begin
  1362. next := sym;
  1363. definition^.first := @self;
  1364. end
  1365. else
  1366. begin
  1367. while (sym^.value <= value) and assigned(sym^.next) do
  1368. sym := sym^.next;
  1369. next := sym^.next;
  1370. sym^.next := @self;
  1371. end;
  1372. end;
  1373. procedure tenumsym.write;
  1374. begin
  1375. tsym.write;
  1376. writedefref(definition);
  1377. writelong(value);
  1378. current_ppu^.writeentry(ibenumsym);
  1379. end;
  1380. {$ifdef GDB}
  1381. procedure tenumsym.concatstabto(asmlist : paasmoutput);
  1382. begin
  1383. {enum elements have no stab !}
  1384. end;
  1385. {$EndIf GDB}
  1386. {****************************************************************************
  1387. TTYPESYM
  1388. ****************************************************************************}
  1389. constructor ttypesym.init(const n : string;d : pdef);
  1390. begin
  1391. tsym.init(n);
  1392. typ:=typesym;
  1393. definition:=d;
  1394. {$ifdef GDB}
  1395. isusedinstab := false;
  1396. {$endif GDB}
  1397. forwardpointer:=nil;
  1398. { this allows to link definitions with the type with declares }
  1399. { them }
  1400. if assigned(definition) then
  1401. if definition^.sym=nil then
  1402. definition^.sym:=@self;
  1403. end;
  1404. constructor ttypesym.load;
  1405. begin
  1406. tsym.load;
  1407. typ:=typesym;
  1408. forwardpointer:=nil;
  1409. {$ifdef GDB}
  1410. isusedinstab := false;
  1411. {$endif GDB}
  1412. definition:=readdefref;
  1413. end;
  1414. destructor ttypesym.done;
  1415. begin
  1416. if assigned(definition) then
  1417. if definition^.sym=@self then
  1418. definition^.sym:=nil;
  1419. inherited done;
  1420. end;
  1421. procedure ttypesym.deref;
  1422. begin
  1423. resolvedef(definition);
  1424. if assigned(definition) then
  1425. begin
  1426. if definition^.sym=nil then
  1427. definition^.sym:=@self;
  1428. if (definition^.deftype=recorddef) and assigned(precdef(definition)^.symtable) and
  1429. (definition^.sym=@self) then
  1430. precdef(definition)^.symtable^.name:=stringdup('record '+name);
  1431. end;
  1432. end;
  1433. procedure ttypesym.write;
  1434. begin
  1435. tsym.write;
  1436. writedefref(definition);
  1437. current_ppu^.writeentry(ibtypesym);
  1438. end;
  1439. procedure ttypesym.load_references;
  1440. begin
  1441. inherited load_references;
  1442. if (definition^.deftype=recorddef) then
  1443. precdef(definition)^.symtable^.load_browser;
  1444. if (definition^.deftype=objectdef) then
  1445. pobjectdef(definition)^.publicsyms^.load_browser;
  1446. end;
  1447. function ttypesym.write_references : boolean;
  1448. begin
  1449. if not inherited write_references then
  1450. { write address of this symbol if record or object
  1451. even if no real refs are there
  1452. because we need it for the symtable }
  1453. if (definition^.deftype=recorddef) or
  1454. (definition^.deftype=objectdef) then
  1455. begin
  1456. writesymref(@self);
  1457. current_ppu^.writeentry(ibsymref);
  1458. end;
  1459. write_references:=true;
  1460. if (definition^.deftype=recorddef) then
  1461. precdef(definition)^.symtable^.write_browser;
  1462. if (definition^.deftype=objectdef) then
  1463. pobjectdef(definition)^.publicsyms^.write_browser;
  1464. end;
  1465. {$ifdef BrowserLog}
  1466. procedure ttypesym.add_to_browserlog;
  1467. begin
  1468. inherited add_to_browserlog;
  1469. if (definition^.deftype=recorddef) then
  1470. precdef(definition)^.symtable^.writebrowserlog;
  1471. if (definition^.deftype=objectdef) then
  1472. pobjectdef(definition)^.publicsyms^.writebrowserlog;
  1473. end;
  1474. {$endif BrowserLog}
  1475. {$ifdef GDB}
  1476. function ttypesym.stabstring : pchar;
  1477. var stabchar : string[2];
  1478. short : string;
  1479. begin
  1480. if definition^.deftype in tagtypes then
  1481. stabchar := 'Tt'
  1482. else
  1483. stabchar := 't';
  1484. short := '"'+name+':'+stabchar+definition^.numberstring
  1485. +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
  1486. stabstring := strpnew(short);
  1487. end;
  1488. procedure ttypesym.concatstabto(asmlist : paasmoutput);
  1489. begin
  1490. {not stabs for forward defs }
  1491. if assigned(definition) then
  1492. if (definition^.sym = @self) then
  1493. definition^.concatstabto(asmlist)
  1494. else
  1495. inherited concatstabto(asmlist);
  1496. end;
  1497. {$endif GDB}
  1498. {****************************************************************************
  1499. TSYSSYM
  1500. ****************************************************************************}
  1501. constructor tsyssym.init(const n : string;l : longint);
  1502. begin
  1503. inherited init(n);
  1504. typ:=syssym;
  1505. number:=l;
  1506. end;
  1507. procedure tsyssym.write;
  1508. begin
  1509. end;
  1510. {$ifdef GDB}
  1511. procedure tsyssym.concatstabto(asmlist : paasmoutput);
  1512. begin
  1513. end;
  1514. {$endif GDB}
  1515. {****************************************************************************
  1516. TMACROSYM
  1517. ****************************************************************************}
  1518. constructor tmacrosym.init(const n : string);
  1519. begin
  1520. inherited init(n);
  1521. typ:=macrosym;
  1522. defined:=true;
  1523. buftext:=nil;
  1524. buflen:=0;
  1525. end;
  1526. destructor tmacrosym.done;
  1527. begin
  1528. if assigned(buftext) then
  1529. freemem(buftext,buflen);
  1530. inherited done;
  1531. end;
  1532. {
  1533. $Log$
  1534. Revision 1.68 1999-01-12 14:25:36 peter
  1535. + BrowserLog for browser.log generation
  1536. + BrowserCol for browser info in TCollections
  1537. * released all other UseBrowser
  1538. Revision 1.67 1998/12/30 22:15:54 peter
  1539. + farpointer type
  1540. * absolutesym now also stores if its far
  1541. Revision 1.66 1998/12/30 13:41:14 peter
  1542. * released valuepara
  1543. Revision 1.65 1998/12/26 15:35:44 peter
  1544. + read/write of constnil
  1545. Revision 1.64 1998/12/08 10:18:15 peter
  1546. + -gh for heaptrc unit
  1547. Revision 1.63 1998/11/28 16:20:56 peter
  1548. + support for dll variables
  1549. Revision 1.62 1998/11/27 14:50:48 peter
  1550. + open strings, $P switch support
  1551. Revision 1.61 1998/11/18 15:44:18 peter
  1552. * VALUEPARA for tp7 compatible value parameters
  1553. Revision 1.60 1998/11/16 10:13:51 peter
  1554. * label defines are checked at the end of the proc
  1555. Revision 1.59 1998/11/13 12:09:11 peter
  1556. * unused label is now a warning
  1557. Revision 1.58 1998/11/10 10:50:57 pierre
  1558. * temporary fix for long mangled procsym names
  1559. Revision 1.57 1998/11/05 23:39:31 peter
  1560. + typedconst.getsize
  1561. Revision 1.56 1998/10/28 18:26:18 pierre
  1562. * removed some erros after other errors (introduced by useexcept)
  1563. * stabs works again correctly (for how long !)
  1564. Revision 1.55 1998/10/20 08:07:00 pierre
  1565. * several memory corruptions due to double freemem solved
  1566. => never use p^.loc.location:=p^.left^.loc.location;
  1567. + finally I added now by default
  1568. that ra386dir translates global and unit symbols
  1569. + added a first field in tsymtable and
  1570. a nextsym field in tsym
  1571. (this allows to obtain ordered type info for
  1572. records and objects in gdb !)
  1573. Revision 1.54 1998/10/19 08:55:07 pierre
  1574. * wrong stabs info corrected once again !!
  1575. + variable vmt offset with vmt field only if required
  1576. implemented now !!!
  1577. Revision 1.53 1998/10/16 08:51:53 peter
  1578. + target_os.stackalignment
  1579. + stack can be aligned at 2 or 4 byte boundaries
  1580. Revision 1.52 1998/10/08 17:17:32 pierre
  1581. * current_module old scanner tagged as invalid if unit is recompiled
  1582. + added ppheap for better info on tracegetmem of heaptrc
  1583. (adds line column and file index)
  1584. * several memory leaks removed ith help of heaptrc !!
  1585. Revision 1.51 1998/10/08 13:48:50 peter
  1586. * fixed memory leaks for do nothing source
  1587. * fixed unit interdependency
  1588. Revision 1.50 1998/10/06 17:16:56 pierre
  1589. * some memory leaks fixed (thanks to Peter for heaptrc !)
  1590. Revision 1.49 1998/10/01 09:22:55 peter
  1591. * fixed value openarray
  1592. * ungettemp of arrayconstruct
  1593. Revision 1.48 1998/09/26 17:45:44 peter
  1594. + idtoken and only one token table
  1595. Revision 1.47 1998/09/24 15:11:17 peter
  1596. * fixed enum for not GDB
  1597. Revision 1.46 1998/09/23 15:39:13 pierre
  1598. * browser bugfixes
  1599. was adding a reference when looking for the symbol
  1600. if -bSYM_NAME was used
  1601. Revision 1.45 1998/09/21 08:45:24 pierre
  1602. + added vmt_offset in tobjectdef.write for fututre use
  1603. (first steps to have objects without vmt if no virtual !!)
  1604. + added fpu_used field for tabstractprocdef :
  1605. sets this level to 2 if the functions return with value in FPU
  1606. (is then set to correct value at parsing of implementation)
  1607. THIS MIGHT refuse some code with FPU expression too complex
  1608. that were accepted before and even in some cases
  1609. that don't overflow in fact
  1610. ( like if f : float; is a forward that finally in implementation
  1611. only uses one fpu register !!)
  1612. Nevertheless I think that it will improve security on
  1613. FPU operations !!
  1614. * most other changes only for UseBrowser code
  1615. (added symtable references for record and objects)
  1616. local switch for refs to args and local of each function
  1617. (static symtable still missing)
  1618. UseBrowser still not stable and probably broken by
  1619. the definition hash array !!
  1620. Revision 1.44 1998/09/18 16:03:47 florian
  1621. * some changes to compile with Delphi
  1622. Revision 1.43 1998/09/18 08:01:38 pierre
  1623. + improvement on the usebrowser part
  1624. (does not work correctly for now)
  1625. Revision 1.42 1998/09/07 19:33:25 florian
  1626. + some stuff for property rtti added:
  1627. - NameIndex of the TPropInfo record is now written correctly
  1628. - the DEFAULT/NODEFAULT keyword is supported now
  1629. - the default value and the storedsym/def are now written to
  1630. the PPU fiel
  1631. Revision 1.41 1998/09/07 18:46:12 peter
  1632. * update smartlinking, uses getdatalabel
  1633. * renamed ptree.value vars to value_str,value_real,value_set
  1634. Revision 1.40 1998/09/07 17:37:04 florian
  1635. * first fixes for published properties
  1636. Revision 1.39 1998/09/05 22:11:02 florian
  1637. + switch -vb
  1638. * while/repeat loops accept now also word/longbool conditions
  1639. * makebooltojump did an invalid ungetregister32, fixed
  1640. Revision 1.38 1998/09/01 12:53:26 peter
  1641. + aktpackenum
  1642. Revision 1.37 1998/09/01 07:54:25 pierre
  1643. * UseBrowser a little updated (might still be buggy !!)
  1644. * bug in psub.pas in function specifier removed
  1645. * stdcall allowed in interface and in implementation
  1646. (FPC will not yet complain if it is missing in either part
  1647. because stdcall is only a dummy !!)
  1648. Revision 1.36 1998/08/25 13:09:26 pierre
  1649. * corrected mangling sheme :
  1650. cvar add Cprefix to the mixed case name whereas
  1651. export or public use direct name
  1652. Revision 1.35 1998/08/25 12:42:46 pierre
  1653. * CDECL changed to CVAR for variables
  1654. specifications are read in structures also
  1655. + started adding GPC compatibility mode ( option -Sp)
  1656. * names changed to lowercase
  1657. Revision 1.34 1998/08/21 14:08:53 pierre
  1658. + TEST_FUNCRET now default (old code removed)
  1659. works also for m68k (at least compiles)
  1660. Revision 1.33 1998/08/20 12:53:27 peter
  1661. * object_options are always written for object syms
  1662. Revision 1.32 1998/08/20 09:26:46 pierre
  1663. + funcret setting in underproc testing
  1664. compile with _dTEST_FUNCRET
  1665. Revision 1.31 1998/08/17 10:10:12 peter
  1666. - removed OLDPPU
  1667. Revision 1.30 1998/08/13 10:57:29 peter
  1668. * constant sets are now written correctly to the ppufile
  1669. Revision 1.29 1998/08/11 15:31:42 peter
  1670. * write extended to ppu file
  1671. * new version 0.99.7
  1672. Revision 1.28 1998/08/11 14:07:27 peter
  1673. * fixed pushing of high value for openarray
  1674. Revision 1.27 1998/08/10 14:50:31 peter
  1675. + localswitches, moduleswitches, globalswitches splitting
  1676. Revision 1.26 1998/08/10 10:18:35 peter
  1677. + Compiler,Comphook unit which are the new interface units to the
  1678. compiler
  1679. Revision 1.25 1998/07/30 11:18:19 florian
  1680. + first implementation of try ... except on .. do end;
  1681. * limitiation of 65535 bytes parameters for cdecl removed
  1682. Revision 1.24 1998/07/20 18:40:16 florian
  1683. * handling of ansi string constants should now work
  1684. Revision 1.23 1998/07/14 21:37:24 peter
  1685. * fixed packrecords as discussed at the alias
  1686. Revision 1.22 1998/07/14 14:47:08 peter
  1687. * released NEWINPUT
  1688. Revision 1.21 1998/07/13 21:17:38 florian
  1689. * changed to compile with TP
  1690. Revision 1.20 1998/07/10 00:00:05 peter
  1691. * fixed ttypesym bug finally
  1692. * fileinfo in the symtable and better using for unused vars
  1693. Revision 1.19 1998/07/07 17:40:39 peter
  1694. * packrecords 4 works
  1695. * word aligning of parameters
  1696. Revision 1.18 1998/07/07 11:20:15 peter
  1697. + NEWINPUT for a better inputfile and scanner object
  1698. Revision 1.17 1998/06/24 14:48:40 peter
  1699. * ifdef newppu -> ifndef oldppu
  1700. Revision 1.16 1998/06/19 15:40:42 peter
  1701. * removed cosntructor/constructor warning and 0.99.5 recompiles it again
  1702. Revision 1.15 1998/06/17 14:10:18 peter
  1703. * small os2 fixes
  1704. * fixed interdependent units with newppu (remake3 under linux works now)
  1705. Revision 1.14 1998/06/16 08:56:34 peter
  1706. + targetcpu
  1707. * cleaner pmodules for newppu
  1708. Revision 1.13 1998/06/15 15:38:10 pierre
  1709. * small bug in systems.pas corrected
  1710. + operators in different units better hanlded
  1711. Revision 1.12 1998/06/15 14:23:44 daniel
  1712. * Reverted my changes.
  1713. Revision 1.10 1998/06/13 00:10:18 peter
  1714. * working browser and newppu
  1715. * some small fixes against crashes which occured in bp7 (but not in
  1716. fpc?!)
  1717. Revision 1.9 1998/06/12 16:15:35 pierre
  1718. * external name 'C_var';
  1719. export name 'intern_C_var';
  1720. cdecl;
  1721. cdecl;external;
  1722. are now supported only with -Sv switch
  1723. Revision 1.8 1998/06/11 10:11:59 peter
  1724. * -gb works again
  1725. Revision 1.7 1998/06/09 16:01:51 pierre
  1726. + added procedure directive parsing for procvars
  1727. (accepted are popstack cdecl and pascal)
  1728. + added C vars with the following syntax
  1729. var C calias 'true_c_name';(can be followed by external)
  1730. reason is that you must add the Cprefix
  1731. which is target dependent
  1732. Revision 1.6 1998/06/08 22:59:53 peter
  1733. * smartlinking works for win32
  1734. * some defines to exclude some compiler parts
  1735. Revision 1.5 1998/06/04 23:52:02 peter
  1736. * m68k compiles
  1737. + .def file creation moved to gendef.pas so it could also be used
  1738. for win32
  1739. Revision 1.4 1998/06/04 09:55:46 pierre
  1740. * demangled name of procsym reworked to become independant of the mangling scheme
  1741. Revision 1.3 1998/06/03 22:14:20 florian
  1742. * problem with sizes of classes fixed (if the anchestor was declared
  1743. forward, the compiler doesn't update the child classes size)
  1744. Revision 1.2 1998/05/28 14:40:29 peter
  1745. * fixes for newppu, remake3 works now with it
  1746. Revision 1.1 1998/05/27 19:45:09 peter
  1747. * symtable.pas splitted into includefiles
  1748. * symtable adapted for $ifndef OLDPPU
  1749. }