symtype.pas 28 KB

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