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,
  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. { stabs debugging }
  47. stab_number : word;
  48. dbg_state : tdefdbgstatus;
  49. defoptions : tdefoptions;
  50. defstates : tdefstates;
  51. constructor create(dt:tdeftyp);
  52. procedure buildderef;virtual;abstract;
  53. procedure buildderefimpl;virtual;abstract;
  54. procedure deref;virtual;abstract;
  55. procedure derefimpl;virtual;abstract;
  56. function typename:string;
  57. function GetTypeName:string;virtual;
  58. function mangledparaname:string;
  59. function getmangledparaname:string;virtual;
  60. function rtti_mangledname(rt:trttitype):string;virtual;abstract;
  61. function size:aint;virtual;abstract;
  62. function packedbitsize:aint;virtual;
  63. function alignment:shortint;virtual;abstract;
  64. function getvardef:longint;virtual;abstract;
  65. function getparentdef:tdef;virtual;
  66. function geTSymtable(t:tgeTSymtable):TSymtable;virtual;
  67. function is_publishable:boolean;virtual;abstract;
  68. function needs_inittable:boolean;virtual;abstract;
  69. function is_related(def:tdef):boolean;virtual;
  70. procedure ChangeOwner(st:TSymtable);
  71. end;
  72. {************************************************
  73. TSym
  74. ************************************************}
  75. { this object is the base for all symbol objects }
  76. { tsym }
  77. tsym = class(TSymEntry)
  78. protected
  79. public
  80. fileinfo : tfileposinfo;
  81. symoptions : tsymoptions;
  82. refs : longint;
  83. reflist : TLinkedList;
  84. isdbgwritten : boolean;
  85. constructor create(st:tsymtyp;const aname:string);
  86. destructor destroy;override;
  87. function mangledname:string; virtual;
  88. procedure buildderef;virtual;
  89. procedure deref;virtual;
  90. { currobjdef is the object def to assume, this is necessary for protected and
  91. private,
  92. context is the object def we're really in, this is for the strict stuff
  93. }
  94. function is_visible_for_object(currobjdef:tdef;context : tdef):boolean;virtual;
  95. procedure ChangeOwner(st:TSymtable);
  96. procedure IncRefCount;
  97. procedure IncRefCountBy(AValue : longint);
  98. procedure MaybeCreateRefList;
  99. procedure AddRef;
  100. end;
  101. tsymarr = array[0..maxlongint div sizeof(pointer)-1] of tsym;
  102. psymarr = ^tsymarr;
  103. {************************************************
  104. TDeref
  105. ************************************************}
  106. tderef = object
  107. dataidx : longint;
  108. procedure reset;
  109. procedure build(s:TObject);
  110. function resolve:TObject;
  111. end;
  112. {************************************************
  113. tpropaccesslist
  114. ************************************************}
  115. ppropaccesslistitem = ^tpropaccesslistitem;
  116. tpropaccesslistitem = record
  117. sltype : tsltype;
  118. next : ppropaccesslistitem;
  119. case byte of
  120. 0 : (sym : tsym; symderef : tderef);
  121. 1 : (value : TConstExprInt; valuedef: tdef; valuedefderef:tderef);
  122. 2 : (def: tdef; defderef:tderef);
  123. end;
  124. tpropaccesslist = class
  125. procdef : tdef;
  126. procdefderef : tderef;
  127. firstsym,
  128. lastsym : ppropaccesslistitem;
  129. constructor create;
  130. destructor destroy;override;
  131. function empty:boolean;
  132. procedure addsym(slt:tsltype;p:tsym);
  133. procedure addconst(slt:tsltype;v:TConstExprInt;d:tdef);
  134. procedure addtype(slt:tsltype;d:tdef);
  135. procedure addsymderef(slt:tsltype;d:tderef);
  136. procedure addconstderef(slt:tsltype;v:TConstExprInt;d:tderef);
  137. procedure addtypederef(slt:tsltype;d:tderef);
  138. procedure clear;
  139. procedure resolve;
  140. procedure buildderef;
  141. end;
  142. {************************************************
  143. Tcompilerppufile
  144. ************************************************}
  145. tcompilerppufile=class(tppufile)
  146. public
  147. procedure checkerror;
  148. procedure getguid(var g: tguid);
  149. function getexprint:tconstexprint;
  150. function getptruint:TConstPtrUInt;
  151. procedure getposinfo(var p:tfileposinfo);
  152. procedure getderef(var d:tderef);
  153. function getpropaccesslist:tpropaccesslist;
  154. function getasmsymbol:tasmsymbol;
  155. procedure putguid(const g: tguid);
  156. procedure putexprint(v:tconstexprint);
  157. procedure PutPtrUInt(v:TConstPtrUInt);
  158. procedure putposinfo(const p:tfileposinfo);
  159. procedure putderef(const d:tderef);
  160. procedure putpropaccesslist(p:tpropaccesslist);
  161. procedure putasmsymbol(s:tasmsymbol);
  162. end;
  163. {$ifdef MEMDEBUG}
  164. var
  165. memmanglednames,
  166. memprocpara,
  167. memprocparast,
  168. memproclocalst,
  169. memprocnodetree : tmemdebug;
  170. {$endif MEMDEBUG}
  171. const
  172. current_object_option : tsymoptions = [sp_public];
  173. function FindUnitSymtable(st:TSymtable):TSymtable;
  174. implementation
  175. uses
  176. crefs,
  177. verbose,
  178. fmodule
  179. ;
  180. {****************************************************************************
  181. Utils
  182. ****************************************************************************}
  183. function FindUnitSymtable(st:TSymtable):TSymtable;
  184. begin
  185. result:=nil;
  186. repeat
  187. if not assigned(st) then
  188. internalerror(200602034);
  189. case st.symtabletype of
  190. localmacrosymtable,
  191. exportedmacrosymtable,
  192. staticsymtable,
  193. globalsymtable :
  194. begin
  195. result:=st;
  196. exit;
  197. end;
  198. recordsymtable,
  199. localsymtable,
  200. parasymtable,
  201. ObjectSymtable :
  202. st:=st.defowner.owner;
  203. else
  204. internalerror(200602035);
  205. end;
  206. until false;
  207. end;
  208. {****************************************************************************
  209. Tdef
  210. ****************************************************************************}
  211. constructor tdef.create(dt:tdeftyp);
  212. begin
  213. inherited create;
  214. typ:=dt;
  215. owner := nil;
  216. typesym := nil;
  217. defoptions:=[];
  218. dbg_state:=dbg_state_unused;
  219. stab_number:=0;
  220. end;
  221. function tdef.typename:string;
  222. begin
  223. if assigned(typesym) and
  224. not(typ in [procvardef,procdef]) and
  225. (typesym.realname[1]<>'$') then
  226. result:=typesym.realname
  227. else
  228. result:=GetTypeName;
  229. end;
  230. function tdef.GetTypeName : string;
  231. begin
  232. GetTypeName:='<unknown type>'
  233. end;
  234. function tdef.mangledparaname:string;
  235. begin
  236. if assigned(typesym) then
  237. mangledparaname:=typesym.name
  238. else
  239. mangledparaname:=getmangledparaname;
  240. end;
  241. function tdef.getmangledparaname:string;
  242. begin
  243. result:='<unknown type>';
  244. end;
  245. function tdef.getparentdef:tdef;
  246. begin
  247. result:=nil;
  248. end;
  249. function tdef.geTSymtable(t:tgeTSymtable):TSymtable;
  250. begin
  251. result:=nil;
  252. end;
  253. function tdef.is_related(def:tdef):boolean;
  254. begin
  255. result:=false;
  256. end;
  257. function tdef.packedbitsize:aint;
  258. begin
  259. result:=size * 8;
  260. end;
  261. procedure tdef.ChangeOwner(st:TSymtable);
  262. begin
  263. // if assigned(Owner) then
  264. // Owner.DefList.List[i]:=nil;
  265. Owner:=st;
  266. Owner.DefList.Add(self);
  267. end;
  268. {****************************************************************************
  269. TSYM (base for all symtypes)
  270. ****************************************************************************}
  271. constructor tsym.create(st:tsymtyp;const aname:string);
  272. begin
  273. inherited CreateNotOwned;
  274. realname:=aname;
  275. typ:=st;
  276. RefList:=nil;
  277. symoptions:=[];
  278. fileinfo:=current_tokenpos;
  279. isdbgwritten := false;
  280. symoptions:=current_object_option;
  281. end;
  282. destructor Tsym.destroy;
  283. begin
  284. if assigned(RefList) then
  285. RefList.Free;
  286. inherited Destroy;
  287. end;
  288. procedure Tsym.IncRefCount;
  289. begin
  290. inc(refs);
  291. if cs_browser in current_settings.moduleswitches then
  292. begin
  293. MaybeCreateRefList;
  294. AddRef;
  295. end;
  296. end;
  297. procedure Tsym.IncRefCountBy(AValue : longint);
  298. begin
  299. inc(refs,AValue);
  300. end;
  301. procedure Tsym.MaybeCreateRefList;
  302. begin
  303. if not assigned(reflist) then
  304. reflist:=TRefLinkedList.create;
  305. end;
  306. procedure Tsym.AddRef;
  307. var
  308. RefItem: TRefItem;
  309. begin
  310. RefItem:=TRefItem.Create(current_tokenpos);
  311. RefList.Concat(RefItem);
  312. end;
  313. procedure Tsym.buildderef;
  314. begin
  315. end;
  316. procedure Tsym.deref;
  317. begin
  318. end;
  319. function tsym.mangledname : string;
  320. begin
  321. internalerror(200204171);
  322. result:='';
  323. end;
  324. function tsym.is_visible_for_object(currobjdef:Tdef;context : tdef):boolean;
  325. begin
  326. is_visible_for_object:=false;
  327. { private symbols are allowed when we are in the same
  328. module as they are defined }
  329. if (sp_private in symoptions) and
  330. assigned(owner.defowner) and
  331. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  332. (not owner.defowner.owner.iscurrentunit) then
  333. exit;
  334. if (sp_strictprivate in symoptions) then
  335. begin
  336. result:=assigned(currobjdef) and
  337. (context=tdef(owner.defowner));
  338. exit;
  339. end;
  340. if (sp_strictprotected in symoptions) then
  341. begin
  342. result:=assigned(context) and
  343. context.is_related(tdef(owner.defowner));
  344. exit;
  345. end;
  346. { protected symbols are visible in the module that defines them and
  347. also visible to related objects }
  348. if (sp_protected in symoptions) and
  349. (
  350. (
  351. assigned(owner.defowner) and
  352. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  353. (not owner.defowner.owner.iscurrentunit)
  354. ) and
  355. not(
  356. assigned(currobjdef) and
  357. (currobjdef.owner.symtabletype in [globalsymtable,staticsymtable]) and
  358. (currobjdef.owner.iscurrentunit) and
  359. currobjdef.is_related(tdef(owner.defowner))
  360. )
  361. ) then
  362. exit;
  363. is_visible_for_object:=true;
  364. end;
  365. procedure tsym.ChangeOwner(st:TSymtable);
  366. begin
  367. // if assigned(Owner) then
  368. // Owner.SymList.List.List^[i].Data:=nil;
  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. {$warning 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. getdata(g,sizeof(g));
  646. end;
  647. function tcompilerppufile.getexprint:tconstexprint;
  648. begin
  649. if sizeof(tconstexprint)=8 then
  650. result:=tconstexprint(getint64)
  651. else
  652. result:=tconstexprint(getlongint);
  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(v:tconstexprint);
  822. begin
  823. if sizeof(TConstExprInt)=8 then
  824. putint64(int64(v))
  825. else if sizeof(TConstExprInt)=4 then
  826. putlongint(longint(v))
  827. else
  828. internalerror(2002082601);
  829. end;
  830. procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
  831. begin
  832. if sizeof(TConstPtrUInt)=8 then
  833. putint64(int64(v))
  834. else if sizeof(TConstPtrUInt)=4 then
  835. putlongint(longint(v))
  836. else
  837. internalerror(2002082601);
  838. end;
  839. procedure tcompilerppufile.putderef(const d:tderef);
  840. var
  841. oldcrc : boolean;
  842. begin
  843. oldcrc:=do_crc;
  844. do_crc:=false;
  845. putlongint(d.dataidx);
  846. do_crc:=oldcrc;
  847. end;
  848. procedure tcompilerppufile.putpropaccesslist(p:tpropaccesslist);
  849. var
  850. hp : ppropaccesslistitem;
  851. begin
  852. putderef(p.procdefderef);
  853. hp:=p.firstsym;
  854. while assigned(hp) do
  855. begin
  856. putbyte(byte(hp^.sltype));
  857. case hp^.sltype of
  858. sl_call,
  859. sl_load,
  860. sl_subscript :
  861. putderef(hp^.symderef);
  862. sl_absolutetype,
  863. sl_typeconv :
  864. putderef(hp^.defderef);
  865. sl_vec :
  866. begin
  867. putlongint(hp^.value);
  868. putderef(hp^.valuedefderef);
  869. end;
  870. else
  871. internalerror(200110205);
  872. end;
  873. hp:=hp^.next;
  874. end;
  875. putbyte(byte(sl_none));
  876. end;
  877. procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
  878. begin
  879. putlongint(0);
  880. end;
  881. {$ifdef MEMDEBUG}
  882. initialization
  883. memmanglednames:=TMemDebug.create('Manglednames');
  884. memmanglednames.stop;
  885. memprocpara:=TMemDebug.create('ProcPara');
  886. memprocpara.stop;
  887. memprocparast:=TMemDebug.create('ProcParaSt');
  888. memprocparast.stop;
  889. memproclocalst:=TMemDebug.create('ProcLocalSt');
  890. memproclocalst.stop;
  891. memprocnodetree:=TMemDebug.create('ProcNodeTree');
  892. memprocnodetree.stop;
  893. finalization
  894. memmanglednames.free;
  895. memprocpara.free;
  896. memprocparast.free;
  897. memproclocalst.free;
  898. memprocnodetree.free;
  899. {$endif MEMDEBUG}
  900. end.