symtype.pas 27 KB

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