2
0

symtype.pas 28 KB

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