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