symtype.pas 28 KB

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