symtype.pas 28 KB

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