symtype.pas 27 KB

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