symtype.pas 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  3. This unit handles the symbol tables
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symtype;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cutils,
  23. cclasses,
  24. { global }
  25. globtype,globals,constexp,
  26. { symtable }
  27. symconst,symbase,
  28. { aasm }
  29. aasmbase,ppu,cpuinfo
  30. ;
  31. type
  32. {************************************************
  33. Required Forwards
  34. ************************************************}
  35. tsym = class;
  36. Tcompilerppufile=class;
  37. {************************************************
  38. TDef
  39. ************************************************}
  40. tgeTSymtable = (gs_none,gs_record,gs_local,gs_para);
  41. tdef = class(TDefEntry)
  42. typesym : tsym; { which type the definition was generated this def }
  43. { maybe it's useful to merge the dwarf and stabs debugging info with some hacking }
  44. { dwarf debugging }
  45. dwarf_lab : tasmsymbol;
  46. dwarf_ref_lab : tasmsymbol;
  47. { stabs debugging }
  48. stab_number : word;
  49. dbg_state : tdefdbgstatus;
  50. defoptions : tdefoptions;
  51. defstates : tdefstates;
  52. constructor create(dt:tdeftyp);
  53. procedure buildderef;virtual;abstract;
  54. procedure buildderefimpl;virtual;abstract;
  55. procedure deref;virtual;abstract;
  56. procedure derefimpl;virtual;abstract;
  57. function typename:string;
  58. function GetTypeName:string;virtual;
  59. function mangledparaname:string;
  60. function getmangledparaname:string;virtual;
  61. function rtti_mangledname(rt:trttitype):string;virtual;abstract;
  62. function size:aint;virtual;abstract;
  63. function packedbitsize:aint;virtual;
  64. function alignment:shortint;virtual;abstract;
  65. function getvardef:longint;virtual;abstract;
  66. function getparentdef:tdef;virtual;
  67. function geTSymtable(t:tgeTSymtable):TSymtable;virtual;
  68. function is_publishable:boolean;virtual;abstract;
  69. function needs_inittable:boolean;virtual;abstract;
  70. function is_related(def:tdef):boolean;virtual;
  71. procedure ChangeOwner(st:TSymtable);
  72. procedure register_created_object_type;virtual;
  73. end;
  74. {************************************************
  75. TSym
  76. ************************************************}
  77. { this object is the base for all symbol objects }
  78. { tsym }
  79. tsym = class(TSymEntry)
  80. protected
  81. public
  82. fileinfo : tfileposinfo;
  83. symoptions : tsymoptions;
  84. refs : longint;
  85. reflist : TLinkedList;
  86. visibility : tvisibility;
  87. { deprecated optionally can have a message }
  88. deprecatedmsg: pshortstring;
  89. isdbgwritten : boolean;
  90. constructor create(st:tsymtyp;const aname:string);
  91. destructor destroy;override;
  92. function mangledname:string; virtual;
  93. function prettyname:string; virtual;
  94. procedure buildderef;virtual;
  95. procedure deref;virtual;
  96. procedure ChangeOwner(st:TSymtable);
  97. procedure IncRefCount;
  98. procedure IncRefCountBy(AValue : longint);
  99. procedure MaybeCreateRefList;
  100. procedure AddRef;
  101. end;
  102. tsymarr = array[0..maxlongint div sizeof(pointer)-1] of tsym;
  103. psymarr = ^tsymarr;
  104. {************************************************
  105. TDeref
  106. ************************************************}
  107. tderef = object
  108. dataidx : longint;
  109. procedure reset;
  110. procedure build(s:TObject);
  111. function resolve:TObject;
  112. end;
  113. {************************************************
  114. tpropaccesslist
  115. ************************************************}
  116. ppropaccesslistitem = ^tpropaccesslistitem;
  117. tpropaccesslistitem = record
  118. sltype : tsltype;
  119. next : ppropaccesslistitem;
  120. case byte of
  121. 0 : (sym : tsym; symderef : tderef);
  122. 1 : (value : TConstExprInt; valuedef: tdef; valuedefderef:tderef);
  123. 2 : (def: tdef; defderef:tderef);
  124. end;
  125. tpropaccesslist = class
  126. procdef : tdef;
  127. procdefderef : tderef;
  128. firstsym,
  129. lastsym : ppropaccesslistitem;
  130. constructor create;
  131. destructor destroy;override;
  132. function empty:boolean;
  133. procedure addsym(slt:tsltype;p:tsym);
  134. procedure addconst(slt:tsltype;v:TConstExprInt;d:tdef);
  135. procedure addtype(slt:tsltype;d:tdef);
  136. procedure addsymderef(slt:tsltype;d:tderef);
  137. procedure addconstderef(slt:tsltype;v:TConstExprInt;d:tderef);
  138. procedure addtypederef(slt:tsltype;d:tderef);
  139. procedure clear;
  140. procedure resolve;
  141. procedure buildderef;
  142. end;
  143. {************************************************
  144. Tcompilerppufile
  145. ************************************************}
  146. tcompilerppufile=class(tppufile)
  147. public
  148. procedure checkerror;
  149. procedure getguid(var g: tguid);
  150. function getexprint:Tconstexprint;
  151. function getptruint:TConstPtrUInt;
  152. procedure getposinfo(var p:tfileposinfo);
  153. procedure getderef(var d:tderef);
  154. function getpropaccesslist:tpropaccesslist;
  155. function getasmsymbol:tasmsymbol;
  156. procedure putguid(const g: tguid);
  157. procedure putexprint(const v:tconstexprint);
  158. procedure PutPtrUInt(v:TConstPtrUInt);
  159. procedure putposinfo(const p:tfileposinfo);
  160. procedure putderef(const d:tderef);
  161. procedure putpropaccesslist(p:tpropaccesslist);
  162. procedure putasmsymbol(s:tasmsymbol);
  163. end;
  164. {$ifdef MEMDEBUG}
  165. var
  166. memmanglednames,
  167. memprocpara,
  168. memprocparast,
  169. memproclocalst,
  170. memprocnodetree : tmemdebug;
  171. {$endif MEMDEBUG}
  172. function FindUnitSymtable(st:TSymtable):TSymtable;
  173. implementation
  174. uses
  175. crefs,
  176. verbose,
  177. fmodule
  178. ;
  179. {****************************************************************************
  180. Utils
  181. ****************************************************************************}
  182. function FindUnitSymtable(st:TSymtable):TSymtable;
  183. begin
  184. result:=nil;
  185. repeat
  186. if not assigned(st) then
  187. internalerror(200602034);
  188. case st.symtabletype of
  189. localmacrosymtable,
  190. exportedmacrosymtable,
  191. staticsymtable,
  192. globalsymtable :
  193. begin
  194. result:=st;
  195. exit;
  196. end;
  197. recordsymtable,
  198. localsymtable,
  199. parasymtable,
  200. ObjectSymtable :
  201. st:=st.defowner.owner;
  202. else
  203. internalerror(200602035);
  204. end;
  205. until false;
  206. end;
  207. {****************************************************************************
  208. Tdef
  209. ****************************************************************************}
  210. constructor tdef.create(dt:tdeftyp);
  211. begin
  212. inherited create;
  213. typ:=dt;
  214. owner := nil;
  215. typesym := nil;
  216. defoptions:=[];
  217. dbg_state:=dbg_state_unused;
  218. stab_number:=0;
  219. end;
  220. function tdef.typename:string;
  221. begin
  222. if assigned(typesym) and
  223. not(typ in [procvardef,procdef]) and
  224. (typesym.realname[1]<>'$') then
  225. result:=typesym.realname
  226. else
  227. result:=GetTypeName;
  228. end;
  229. function tdef.GetTypeName : string;
  230. begin
  231. GetTypeName:='<unknown type>'
  232. end;
  233. function tdef.mangledparaname:string;
  234. begin
  235. if assigned(typesym) then
  236. mangledparaname:=typesym.name
  237. else
  238. mangledparaname:=getmangledparaname;
  239. end;
  240. function tdef.getmangledparaname:string;
  241. begin
  242. result:='<unknown type>';
  243. end;
  244. function tdef.getparentdef:tdef;
  245. begin
  246. result:=nil;
  247. end;
  248. function tdef.geTSymtable(t:tgeTSymtable):TSymtable;
  249. begin
  250. result:=nil;
  251. end;
  252. function tdef.is_related(def:tdef):boolean;
  253. begin
  254. result:=false;
  255. end;
  256. function tdef.packedbitsize:aint;
  257. begin
  258. result:=size * 8;
  259. end;
  260. procedure tdef.ChangeOwner(st:TSymtable);
  261. begin
  262. // if assigned(Owner) then
  263. // Owner.DefList.List[i]:=nil;
  264. Owner:=st;
  265. Owner.DefList.Add(self);
  266. end;
  267. procedure tdef.register_created_object_type;
  268. begin
  269. end;
  270. {****************************************************************************
  271. TSYM (base for all symtypes)
  272. ****************************************************************************}
  273. constructor tsym.create(st:tsymtyp;const aname:string);
  274. begin
  275. inherited CreateNotOwned;
  276. realname:=aname;
  277. typ:=st;
  278. RefList:=nil;
  279. symoptions:=[];
  280. fileinfo:=current_tokenpos;
  281. isdbgwritten := false;
  282. visibility:=vis_public;
  283. deprecatedmsg:=nil;
  284. end;
  285. destructor Tsym.destroy;
  286. begin
  287. stringdispose(deprecatedmsg);
  288. if assigned(RefList) then
  289. RefList.Free;
  290. inherited Destroy;
  291. end;
  292. procedure Tsym.IncRefCount;
  293. begin
  294. inc(refs);
  295. if cs_browser in current_settings.moduleswitches then
  296. begin
  297. MaybeCreateRefList;
  298. AddRef;
  299. end;
  300. end;
  301. procedure Tsym.IncRefCountBy(AValue : longint);
  302. begin
  303. inc(refs,AValue);
  304. end;
  305. procedure Tsym.MaybeCreateRefList;
  306. begin
  307. if not assigned(reflist) then
  308. reflist:=TRefLinkedList.create;
  309. end;
  310. procedure Tsym.AddRef;
  311. var
  312. RefItem: TRefItem;
  313. begin
  314. RefItem:=TRefItem.Create(current_tokenpos);
  315. RefList.Concat(RefItem);
  316. end;
  317. procedure Tsym.buildderef;
  318. begin
  319. end;
  320. procedure Tsym.deref;
  321. begin
  322. end;
  323. function tsym.mangledname : string;
  324. begin
  325. internalerror(200204171);
  326. result:='';
  327. end;
  328. function tsym.prettyname : string;
  329. begin
  330. result:=realname;
  331. end;
  332. procedure tsym.ChangeOwner(st:TSymtable);
  333. begin
  334. Owner:=st;
  335. inherited ChangeOwner(Owner.SymList);
  336. end;
  337. {****************************************************************************
  338. tpropaccesslist
  339. ****************************************************************************}
  340. constructor tpropaccesslist.create;
  341. begin
  342. procdef:=nil; { needed for procedures }
  343. firstsym:=nil;
  344. lastsym:=nil;
  345. end;
  346. destructor tpropaccesslist.destroy;
  347. begin
  348. clear;
  349. end;
  350. function tpropaccesslist.empty:boolean;
  351. begin
  352. empty:=(firstsym=nil);
  353. end;
  354. procedure tpropaccesslist.clear;
  355. var
  356. hp : ppropaccesslistitem;
  357. begin
  358. while assigned(firstsym) do
  359. begin
  360. hp:=firstsym;
  361. firstsym:=firstsym^.next;
  362. dispose(hp);
  363. end;
  364. firstsym:=nil;
  365. lastsym:=nil;
  366. procdef:=nil;
  367. end;
  368. procedure tpropaccesslist.addsym(slt:tsltype;p:tsym);
  369. var
  370. hp : ppropaccesslistitem;
  371. begin
  372. new(hp);
  373. fillchar(hp^,sizeof(tpropaccesslistitem),0);
  374. hp^.sltype:=slt;
  375. hp^.sym:=p;
  376. hp^.symderef.reset;
  377. if assigned(lastsym) then
  378. lastsym^.next:=hp
  379. else
  380. firstsym:=hp;
  381. lastsym:=hp;
  382. end;
  383. procedure tpropaccesslist.addconst(slt:tsltype;v:TConstExprInt;d:tdef);
  384. var
  385. hp : ppropaccesslistitem;
  386. begin
  387. new(hp);
  388. fillchar(hp^,sizeof(tpropaccesslistitem),0);
  389. hp^.sltype:=slt;
  390. hp^.value:=v;
  391. hp^.valuedef:=d;
  392. hp^.valuedefderef.reset;
  393. if assigned(lastsym) then
  394. lastsym^.next:=hp
  395. else
  396. firstsym:=hp;
  397. lastsym:=hp;
  398. end;
  399. procedure tpropaccesslist.addtype(slt:tsltype;d:tdef);
  400. var
  401. hp : ppropaccesslistitem;
  402. begin
  403. new(hp);
  404. fillchar(hp^,sizeof(tpropaccesslistitem),0);
  405. hp^.sltype:=slt;
  406. hp^.def:=d;
  407. hp^.defderef.reset;
  408. if assigned(lastsym) then
  409. lastsym^.next:=hp
  410. else
  411. firstsym:=hp;
  412. lastsym:=hp;
  413. end;
  414. procedure tpropaccesslist.addsymderef(slt:tsltype;d:tderef);
  415. begin
  416. addsym(slt,nil);
  417. lastsym^.symderef:=d;
  418. end;
  419. procedure tpropaccesslist.addconstderef(slt:tsltype;v:TConstExprInt;d:tderef);
  420. begin
  421. addconst(slt,v,nil);
  422. lastsym^.valuedefderef:=d;
  423. end;
  424. procedure tpropaccesslist.addtypederef(slt:tsltype;d:tderef);
  425. begin
  426. addtype(slt,nil);
  427. lastsym^.defderef:=d;
  428. end;
  429. procedure tpropaccesslist.resolve;
  430. var
  431. hp : ppropaccesslistitem;
  432. begin
  433. procdef:=tdef(procdefderef.resolve);
  434. hp:=firstsym;
  435. while assigned(hp) do
  436. begin
  437. case hp^.sltype of
  438. sl_call,
  439. sl_load,
  440. sl_subscript :
  441. hp^.sym:=tsym(hp^.symderef.resolve);
  442. sl_absolutetype,
  443. sl_typeconv :
  444. hp^.def:=tdef(hp^.defderef.resolve);
  445. sl_vec:
  446. hp^.valuedef:=tdef(hp^.valuedefderef.resolve);
  447. else
  448. internalerror(200110205);
  449. end;
  450. hp:=hp^.next;
  451. end;
  452. end;
  453. procedure tpropaccesslist.buildderef;
  454. var
  455. hp : ppropaccesslistitem;
  456. begin
  457. procdefderef.build(procdef);
  458. hp:=firstsym;
  459. while assigned(hp) do
  460. begin
  461. case hp^.sltype of
  462. sl_call,
  463. sl_load,
  464. sl_subscript :
  465. hp^.symderef.build(hp^.sym);
  466. sl_absolutetype,
  467. sl_typeconv :
  468. hp^.defderef.build(hp^.def);
  469. sl_vec:
  470. hp^.valuedefderef.build(hp^.valuedef);
  471. else
  472. internalerror(200110205);
  473. end;
  474. hp:=hp^.next;
  475. end;
  476. end;
  477. {****************************************************************************
  478. Tderef
  479. ****************************************************************************}
  480. procedure tderef.reset;
  481. begin
  482. dataidx:=-1;
  483. end;
  484. procedure tderef.build(s:TObject);
  485. var
  486. len : byte;
  487. st : TSymtable;
  488. data : array[0..255] of byte;
  489. idx : word;
  490. begin
  491. { skip length byte }
  492. len:=1;
  493. if assigned(s) then
  494. begin
  495. { TODO: ugly hack}
  496. if s is tsym then
  497. st:=FindUnitSymtable(tsym(s).owner)
  498. else
  499. st:=FindUnitSymtable(tdef(s).owner);
  500. if not st.iscurrentunit then
  501. begin
  502. { register that the unit is needed for resolving }
  503. data[len]:=ord(deref_unit);
  504. idx:=current_module.derefidx_unit(st.moduleid);
  505. data[len+1]:=idx shr 8 and $ff;
  506. data[len+2]:=idx and $ff;
  507. inc(len,3);
  508. end;
  509. if s is tsym then
  510. begin
  511. data[len]:=ord(deref_symid);
  512. data[len+1]:=tsym(s).symid shr 24 and $ff;
  513. data[len+2]:=tsym(s).symid shr 16 and $ff;
  514. data[len+3]:=tsym(s).symid shr 8 and $ff;
  515. data[len+4]:=tsym(s).symid and $ff;
  516. inc(len,5);
  517. end
  518. else
  519. begin
  520. data[len]:=ord(deref_defid);
  521. data[len+1]:=tdef(s).defid shr 24 and $ff;
  522. data[len+2]:=tdef(s).defid shr 16 and $ff;
  523. data[len+3]:=tdef(s).defid shr 8 and $ff;
  524. data[len+4]:=tdef(s).defid and $ff;
  525. inc(len,5);
  526. end;
  527. end
  528. else
  529. begin
  530. { nil pointer }
  531. data[len]:=ord(deref_nil);
  532. inc(len);
  533. end;
  534. { store data length in first byte }
  535. data[0]:=len-1;
  536. { store index and write to derefdata }
  537. dataidx:=current_module.derefdata.size;
  538. current_module.derefdata.write(data,len);
  539. end;
  540. function tderef.resolve:TObject;
  541. var
  542. pm : tmodule;
  543. typ : tdereftype;
  544. idx : longint;
  545. i : aint;
  546. len : byte;
  547. data : array[0..255] of byte;
  548. begin
  549. result:=nil;
  550. { not initialized or error }
  551. if dataidx<0 then
  552. internalerror(200306067);
  553. { read data }
  554. current_module.derefdata.seek(dataidx);
  555. if current_module.derefdata.read(len,1)<>1 then
  556. internalerror(200310221);
  557. if len>0 then
  558. begin
  559. if current_module.derefdata.read(data,len)<>len then
  560. internalerror(200310222);
  561. end;
  562. { process data }
  563. pm:=current_module;
  564. i:=0;
  565. while (i<len) do
  566. begin
  567. typ:=tdereftype(data[i]);
  568. inc(i);
  569. case typ of
  570. deref_unit :
  571. begin
  572. idx:=(data[i] shl 8) or data[i+1];
  573. inc(i,2);
  574. pm:=current_module.resolve_unit(idx);
  575. end;
  576. deref_defid :
  577. begin
  578. idx:=longint((data[i] shl 24) or (data[i+1] shl 16) or (data[i+2] shl 8) or data[i+3]);
  579. inc(i,4);
  580. result:=tdef(pm.deflist[idx]);
  581. end;
  582. deref_symid :
  583. begin
  584. idx:=longint((data[i] shl 24) or (data[i+1] shl 16) or (data[i+2] shl 8) or data[i+3]);
  585. inc(i,4);
  586. result:=tsym(pm.symlist[idx]);
  587. end;
  588. deref_nil :
  589. begin
  590. result:=nil;
  591. { Only allowed when no other deref is available }
  592. if len<>1 then
  593. internalerror(200306232);
  594. end;
  595. else
  596. internalerror(200212277);
  597. end;
  598. end;
  599. end;
  600. {*****************************************************************************
  601. TCompilerPPUFile
  602. *****************************************************************************}
  603. procedure tcompilerppufile.checkerror;
  604. begin
  605. if error then
  606. Message(unit_f_ppu_read_error);
  607. end;
  608. procedure tcompilerppufile.getguid(var g: tguid);
  609. begin
  610. longint(g.d1):=getlongint;
  611. g.d2:=getword;
  612. g.d3:=getword;
  613. getdata(g.d4,sizeof(g.d4));
  614. end;
  615. function tcompilerppufile.getexprint:Tconstexprint;
  616. begin
  617. getexprint.overflow:=false;
  618. getexprint.signed:=boolean(getbyte);
  619. getexprint.svalue:=getint64;
  620. end;
  621. function tcompilerppufile.getPtrUInt:TConstPtrUInt;
  622. begin
  623. {$if sizeof(TConstPtrUInt)=8}
  624. result:=tconstptruint(getint64);
  625. {$else}
  626. result:=TConstPtrUInt(getlongint);
  627. {$endif}
  628. end;
  629. procedure tcompilerppufile.getposinfo(var p:tfileposinfo);
  630. var
  631. info : byte;
  632. begin
  633. {
  634. info byte layout in bits:
  635. 0-1 - amount of bytes for fileindex
  636. 2-3 - amount of bytes for line
  637. 4-5 - amount of bytes for column
  638. }
  639. info:=getbyte;
  640. case (info and $03) of
  641. 0 : p.fileindex:=getbyte;
  642. 1 : p.fileindex:=getword;
  643. 2 : p.fileindex:=(getbyte shl 16) or getword;
  644. 3 : p.fileindex:=getlongint;
  645. end;
  646. case ((info shr 2) and $03) of
  647. 0 : p.line:=getbyte;
  648. 1 : p.line:=getword;
  649. 2 : p.line:=(getbyte shl 16) or getword;
  650. 3 : p.line:=getlongint;
  651. end;
  652. case ((info shr 4) and $03) of
  653. 0 : p.column:=getbyte;
  654. 1 : p.column:=getword;
  655. 2 : p.column:=(getbyte shl 16) or getword;
  656. 3 : p.column:=getlongint;
  657. end;
  658. p.moduleindex:=current_module.unit_index;
  659. end;
  660. procedure tcompilerppufile.getderef(var d:tderef);
  661. begin
  662. d.dataidx:=getlongint;
  663. end;
  664. function tcompilerppufile.getpropaccesslist:tpropaccesslist;
  665. var
  666. hderef : tderef;
  667. slt : tsltype;
  668. idx : longint;
  669. p : tpropaccesslist;
  670. begin
  671. p:=tpropaccesslist.create;
  672. getderef(p.procdefderef);
  673. repeat
  674. slt:=tsltype(getbyte);
  675. case slt of
  676. sl_none :
  677. break;
  678. sl_call,
  679. sl_load,
  680. sl_subscript :
  681. begin
  682. getderef(hderef);
  683. p.addsymderef(slt,hderef);
  684. end;
  685. sl_absolutetype,
  686. sl_typeconv :
  687. begin
  688. getderef(hderef);
  689. p.addtypederef(slt,hderef);
  690. end;
  691. sl_vec :
  692. begin
  693. idx:=getlongint;
  694. getderef(hderef);
  695. p.addconstderef(slt,idx,hderef);
  696. end;
  697. else
  698. internalerror(200110204);
  699. end;
  700. until false;
  701. getpropaccesslist:=tpropaccesslist(p);
  702. end;
  703. function tcompilerppufile.getasmsymbol:tasmsymbol;
  704. begin
  705. getlongint;
  706. getasmsymbol:=nil;
  707. end;
  708. procedure tcompilerppufile.putposinfo(const p:tfileposinfo);
  709. var
  710. oldcrc : boolean;
  711. info : byte;
  712. begin
  713. { posinfo is not relevant for changes in PPU }
  714. oldcrc:=do_crc;
  715. do_crc:=false;
  716. {
  717. info byte layout in bits:
  718. 0-1 - amount of bytes for fileindex
  719. 2-3 - amount of bytes for line
  720. 4-5 - amount of bytes for column
  721. }
  722. info:=0;
  723. { calculate info byte }
  724. if (p.fileindex>$ff) then
  725. begin
  726. info:=info or $1;
  727. { uncomment this code if tfileposinfo.fileindex type was changed
  728. if (p.fileindex<=$ffff) then
  729. info:=info or $1
  730. else
  731. if (p.fileindex<=$ffffff) then
  732. info:=info or $2
  733. else
  734. info:=info or $3;
  735. }
  736. end;
  737. if (p.line>$ff) then
  738. begin
  739. if (p.line<=$ffff) then
  740. info:=info or $4
  741. else
  742. if (p.line<=$ffffff) then
  743. info:=info or $8
  744. else
  745. info:=info or $c;
  746. end;
  747. if (p.column>$ff) then
  748. begin
  749. info:=info or $10;
  750. { uncomment this code if tfileposinfo.column type was changed
  751. if (p.column<=$ffff) then
  752. info:=info or $10
  753. else
  754. if (p.column<=$ffffff) then
  755. info:=info or $20
  756. else
  757. info:=info or $30;
  758. }
  759. end;
  760. { write data }
  761. putbyte(info);
  762. case (info and $03) of
  763. 0 : putbyte(p.fileindex);
  764. 1 : putword(p.fileindex);
  765. 2 : begin
  766. putbyte(p.fileindex shr 16);
  767. putword(p.fileindex and $ffff);
  768. end;
  769. 3 : putlongint(p.fileindex);
  770. end;
  771. case ((info shr 2) and $03) of
  772. 0 : putbyte(p.line);
  773. 1 : putword(p.line);
  774. 2 : begin
  775. putbyte(p.line shr 16);
  776. putword(p.line and $ffff);
  777. end;
  778. 3 : putlongint(p.line);
  779. end;
  780. case ((info shr 4) and $03) of
  781. 0 : putbyte(p.column);
  782. 1 : putword(p.column);
  783. 2 : begin
  784. putbyte(p.column shr 16);
  785. putword(p.column and $ffff);
  786. end;
  787. 3 : putlongint(p.column);
  788. end;
  789. do_crc:=oldcrc;
  790. end;
  791. procedure tcompilerppufile.putguid(const g: tguid);
  792. begin
  793. putlongint(longint(g.d1));
  794. putword(g.d2);
  795. putword(g.d3);
  796. putdata(g.d4,sizeof(g.d4));
  797. end;
  798. procedure Tcompilerppufile.putexprint(const v:Tconstexprint);
  799. begin
  800. if v.overflow then
  801. internalerror(200706102);
  802. putbyte(byte(v.signed));
  803. putint64(v.svalue);
  804. end;
  805. procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
  806. begin
  807. {$if sizeof(TConstPtrUInt)=8}
  808. putint64(int64(v));
  809. {$else}
  810. {$if sizeof(TConstPtrUInt)=4}
  811. putlongint(longint(v));
  812. {$else}
  813. internalerror(2002082601);
  814. {$endif} {$endif}
  815. end;
  816. procedure tcompilerppufile.putderef(const d:tderef);
  817. var
  818. oldcrc : boolean;
  819. begin
  820. oldcrc:=do_crc;
  821. do_crc:=false;
  822. putlongint(d.dataidx);
  823. do_crc:=oldcrc;
  824. end;
  825. procedure tcompilerppufile.putpropaccesslist(p:tpropaccesslist);
  826. var
  827. hp : ppropaccesslistitem;
  828. begin
  829. putderef(p.procdefderef);
  830. hp:=p.firstsym;
  831. while assigned(hp) do
  832. begin
  833. putbyte(byte(hp^.sltype));
  834. case hp^.sltype of
  835. sl_call,
  836. sl_load,
  837. sl_subscript :
  838. putderef(hp^.symderef);
  839. sl_absolutetype,
  840. sl_typeconv :
  841. putderef(hp^.defderef);
  842. sl_vec :
  843. begin
  844. putlongint(int64(hp^.value));
  845. putderef(hp^.valuedefderef);
  846. end;
  847. else
  848. internalerror(200110205);
  849. end;
  850. hp:=hp^.next;
  851. end;
  852. putbyte(byte(sl_none));
  853. end;
  854. procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
  855. begin
  856. putlongint(0);
  857. end;
  858. {$ifdef MEMDEBUG}
  859. initialization
  860. memmanglednames:=TMemDebug.create('Manglednames');
  861. memmanglednames.stop;
  862. memprocpara:=TMemDebug.create('ProcPara');
  863. memprocpara.stop;
  864. memprocparast:=TMemDebug.create('ProcParaSt');
  865. memprocparast.stop;
  866. memproclocalst:=TMemDebug.create('ProcLocalSt');
  867. memproclocalst.stop;
  868. memprocnodetree:=TMemDebug.create('ProcNodeTree');
  869. memprocnodetree.stop;
  870. finalization
  871. memmanglednames.free;
  872. memprocpara.free;
  873. memprocparast.free;
  874. memproclocalst.free;
  875. memprocnodetree.free;
  876. {$endif MEMDEBUG}
  877. end.