symppu.pas 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  4. Implementation of the reading of PPU Files for the symtable
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit symppu;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. cclasses,
  23. globtype,globals,
  24. cpuinfo,aasmbase,
  25. symbase,symtype,
  26. ppu;
  27. type
  28. tcompilerppufile=class(tppufile)
  29. public
  30. procedure checkerror;
  31. procedure getguid(var g: tguid);
  32. function getexprint:tconstexprint;
  33. function getptruint:TConstPtrUInt;
  34. procedure getposinfo(var p:tfileposinfo);
  35. procedure getderef(var d:tderef);
  36. function getsymlist:tsymlist;
  37. procedure gettype(var t:ttype);
  38. function getasmsymbol:tasmsymbol;
  39. procedure putguid(const g: tguid);
  40. procedure putexprint(v:tconstexprint);
  41. procedure PutPtrUInt(v:TConstPtrUInt);
  42. procedure putposinfo(const p:tfileposinfo);
  43. procedure putderef(const d:tderef);
  44. procedure putsymlist(p:tsymlist);
  45. procedure puttype(const t:ttype);
  46. procedure putasmsymbol(s:tasmsymbol);
  47. end;
  48. implementation
  49. uses
  50. symconst,
  51. verbose;
  52. {*****************************************************************************
  53. TCompilerPPUFile
  54. *****************************************************************************}
  55. procedure tcompilerppufile.checkerror;
  56. begin
  57. if error then
  58. Message(unit_f_ppu_read_error);
  59. end;
  60. procedure tcompilerppufile.getguid(var g: tguid);
  61. begin
  62. getdata(g,sizeof(g));
  63. end;
  64. function tcompilerppufile.getexprint:tconstexprint;
  65. var
  66. l1,l2 : longint;
  67. begin
  68. if sizeof(tconstexprint)=8 then
  69. begin
  70. l1:=getlongint;
  71. l2:=getlongint;
  72. {$ifopt R+}
  73. {$define Range_check_on}
  74. {$endif opt R+}
  75. {$R- needed here }
  76. {$ifdef Delphi}
  77. result:=int64(l1)+(int64(l2) shl 32);
  78. {$else}
  79. result:=qword(l1)+(int64(l2) shl 32);
  80. {$endif}
  81. {$ifdef Range_check_on}
  82. {$R+}
  83. {$undef Range_check_on}
  84. {$endif Range_check_on}
  85. end
  86. else
  87. result:=getlongint;
  88. end;
  89. function tcompilerppufile.getPtrUInt:TConstPtrUInt;
  90. var
  91. l1,l2 : longint;
  92. begin
  93. if sizeof(tconstexprint)=8 then
  94. begin
  95. l1:=getlongint;
  96. l2:=getlongint;
  97. {$ifopt R+}
  98. {$define Range_check_on}
  99. {$endif opt R+}
  100. {$R- needed here }
  101. {$ifdef Delphi}
  102. result:=int64(l1)+(int64(l2) shl 32);
  103. {$else}
  104. result:=qword(l1)+(int64(l2) shl 32);
  105. {$endif}
  106. {$ifdef Range_check_on}
  107. {$R+}
  108. {$undef Range_check_on}
  109. {$endif Range_check_on}
  110. end
  111. else
  112. result:=getlongint;
  113. end;
  114. procedure tcompilerppufile.getposinfo(var p:tfileposinfo);
  115. var
  116. info : byte;
  117. begin
  118. {
  119. info byte layout in bits:
  120. 0-1 - amount of bytes for fileindex
  121. 2-3 - amount of bytes for line
  122. 4-5 - amount of bytes for column
  123. }
  124. info:=getbyte;
  125. case (info and $03) of
  126. 0 : p.fileindex:=getbyte;
  127. 1 : p.fileindex:=getword;
  128. 2 : p.fileindex:=(getbyte shl 16) or getword;
  129. 3 : p.fileindex:=getlongint;
  130. end;
  131. case ((info shr 2) and $03) of
  132. 0 : p.line:=getbyte;
  133. 1 : p.line:=getword;
  134. 2 : p.line:=(getbyte shl 16) or getword;
  135. 3 : p.line:=getlongint;
  136. end;
  137. case ((info shr 4) and $03) of
  138. 0 : p.column:=getbyte;
  139. 1 : p.column:=getword;
  140. 2 : p.column:=(getbyte shl 16) or getword;
  141. 3 : p.column:=getlongint;
  142. end;
  143. end;
  144. procedure tcompilerppufile.getderef(var d:tderef);
  145. begin
  146. d.dataidx:=getlongint;
  147. end;
  148. function tcompilerppufile.getsymlist:tsymlist;
  149. var
  150. symderef : tderef;
  151. tt : ttype;
  152. slt : tsltype;
  153. idx : longint;
  154. p : tsymlist;
  155. begin
  156. p:=tsymlist.create;
  157. getderef(p.procdefderef);
  158. repeat
  159. slt:=tsltype(getbyte);
  160. case slt of
  161. sl_none :
  162. break;
  163. sl_call,
  164. sl_load,
  165. sl_subscript :
  166. begin
  167. getderef(symderef);
  168. p.addsymderef(slt,symderef);
  169. end;
  170. sl_typeconv :
  171. begin
  172. gettype(tt);
  173. p.addtype(slt,tt);
  174. end;
  175. sl_vec :
  176. begin
  177. idx:=getlongint;
  178. p.addconst(slt,idx);
  179. end;
  180. else
  181. internalerror(200110204);
  182. end;
  183. until false;
  184. getsymlist:=tsymlist(p);
  185. end;
  186. procedure tcompilerppufile.gettype(var t:ttype);
  187. begin
  188. getderef(t.deref);
  189. t.def:=nil;
  190. t.sym:=nil;
  191. end;
  192. function tcompilerppufile.getasmsymbol:tasmsymbol;
  193. begin
  194. getasmsymbol:=tasmsymbol(pointer(getlongint));
  195. end;
  196. procedure tcompilerppufile.putposinfo(const p:tfileposinfo);
  197. var
  198. oldcrc : boolean;
  199. info : byte;
  200. begin
  201. { posinfo is not relevant for changes in PPU }
  202. oldcrc:=do_crc;
  203. do_crc:=false;
  204. {
  205. info byte layout in bits:
  206. 0-1 - amount of bytes for fileindex
  207. 2-3 - amount of bytes for line
  208. 4-5 - amount of bytes for column
  209. }
  210. info:=0;
  211. { calculate info byte }
  212. if (p.fileindex>$ff) then
  213. begin
  214. if (p.fileindex<=$ffff) then
  215. info:=info or $1
  216. else
  217. if (p.fileindex<=$ffffff) then
  218. info:=info or $2
  219. else
  220. info:=info or $3;
  221. end;
  222. if (p.line>$ff) then
  223. begin
  224. if (p.line<=$ffff) then
  225. info:=info or $4
  226. else
  227. if (p.line<=$ffffff) then
  228. info:=info or $8
  229. else
  230. info:=info or $c;
  231. end;
  232. if (p.column>$ff) then
  233. begin
  234. if (p.column<=$ffff) then
  235. info:=info or $10
  236. else
  237. if (p.column<=$ffffff) then
  238. info:=info or $20
  239. else
  240. info:=info or $30;
  241. end;
  242. { write data }
  243. putbyte(info);
  244. case (info and $03) of
  245. 0 : putbyte(p.fileindex);
  246. 1 : putword(p.fileindex);
  247. 2 : begin
  248. putbyte(p.fileindex shr 16);
  249. putword(p.fileindex and $ffff);
  250. end;
  251. 3 : putlongint(p.fileindex);
  252. end;
  253. case ((info shr 2) and $03) of
  254. 0 : putbyte(p.line);
  255. 1 : putword(p.line);
  256. 2 : begin
  257. putbyte(p.line shr 16);
  258. putword(p.line and $ffff);
  259. end;
  260. 3 : putlongint(p.line);
  261. end;
  262. case ((info shr 4) and $03) of
  263. 0 : putbyte(p.column);
  264. 1 : putword(p.column);
  265. 2 : begin
  266. putbyte(p.column shr 16);
  267. putword(p.column and $ffff);
  268. end;
  269. 3 : putlongint(p.column);
  270. end;
  271. do_crc:=oldcrc;
  272. end;
  273. procedure tcompilerppufile.putguid(const g: tguid);
  274. begin
  275. putdata(g,sizeof(g));
  276. end;
  277. procedure tcompilerppufile.putexprint(v:tconstexprint);
  278. begin
  279. if sizeof(TConstExprInt)=8 then
  280. begin
  281. putlongint(longint(lo(v)));
  282. putlongint(longint(hi(v)));
  283. end
  284. else if sizeof(TConstExprInt)=4 then
  285. putlongint(longint(v))
  286. else
  287. internalerror(2002082601);
  288. end;
  289. procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
  290. begin
  291. if sizeof(TConstPtrUInt)=8 then
  292. begin
  293. putlongint(longint(lo(v)));
  294. putlongint(longint(hi(v)));
  295. end
  296. else if sizeof(TConstPtrUInt)=4 then
  297. putlongint(longint(v))
  298. else
  299. internalerror(2002082601);
  300. end;
  301. procedure tcompilerppufile.putderef(const d:tderef);
  302. var
  303. oldcrc : boolean;
  304. begin
  305. oldcrc:=do_crc;
  306. do_crc:=false;
  307. putlongint(d.dataidx);
  308. do_crc:=oldcrc;
  309. end;
  310. procedure tcompilerppufile.putsymlist(p:tsymlist);
  311. var
  312. hp : psymlistitem;
  313. begin
  314. putderef(p.procdefderef);
  315. hp:=p.firstsym;
  316. while assigned(hp) do
  317. begin
  318. putbyte(byte(hp^.sltype));
  319. case hp^.sltype of
  320. sl_call,
  321. sl_load,
  322. sl_subscript :
  323. putderef(hp^.symderef);
  324. sl_typeconv :
  325. puttype(hp^.tt);
  326. sl_vec :
  327. putlongint(hp^.value);
  328. else
  329. internalerror(200110205);
  330. end;
  331. hp:=hp^.next;
  332. end;
  333. putbyte(byte(sl_none));
  334. end;
  335. procedure tcompilerppufile.puttype(const t:ttype);
  336. begin
  337. putderef(t.deref);
  338. end;
  339. procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
  340. begin
  341. if assigned(s) then
  342. begin
  343. if s.ppuidx=-1 then
  344. begin
  345. inc(objectlibrary.asmsymbolppuidx);
  346. s.ppuidx:=objectlibrary.asmsymbolppuidx;
  347. end;
  348. putlongint(s.ppuidx);
  349. end
  350. else
  351. putlongint(0);
  352. end;
  353. end.
  354. {
  355. $Log$
  356. Revision 1.23 2003-10-28 15:36:01 peter
  357. * absolute to object field supported, fixes tb0458
  358. Revision 1.22 2003/10/23 14:44:07 peter
  359. * splitted buildderef and buildderefimpl to fix interface crc
  360. calculation
  361. Revision 1.21 2003/10/22 20:40:00 peter
  362. * write derefdata in a separate ppu entry
  363. Revision 1.20 2003/10/07 16:06:30 peter
  364. * tsymlist.def renamed to tsymlist.procdef
  365. * tsymlist.procdef is now only used to store the procdef
  366. Revision 1.19 2003/06/07 20:26:32 peter
  367. * re-resolving added instead of reloading from ppu
  368. * tderef object added to store deref info for resolving
  369. Revision 1.18 2002/12/21 13:07:34 peter
  370. * type redefine fix for tb0437
  371. Revision 1.17 2002/10/05 12:43:29 carl
  372. * fixes for Delphi 6 compilation
  373. (warning : Some features do not work under Delphi)
  374. Revision 1.16 2002/08/26 14:05:57 pierre
  375. * fixed compilation cycle with -Cr option by adding explicit
  376. longint typecast in PutPtrUInt and putexprint methods.
  377. + added checks for sizeof and internalerros if size is not handled.
  378. Revision 1.15 2002/08/18 20:06:26 peter
  379. * inlining is now also allowed in interface
  380. * renamed write/load to ppuwrite/ppuload
  381. * tnode storing in ppu
  382. * nld,ncon,nbas are already updated for storing in ppu
  383. Revision 1.14 2002/08/11 14:32:28 peter
  384. * renamed current_library to objectlibrary
  385. Revision 1.13 2002/08/11 13:24:14 peter
  386. * saving of asmsymbols in ppu supported
  387. * asmsymbollist global is removed and moved into a new class
  388. tasmlibrarydata that will hold the info of a .a file which
  389. corresponds with a single module. Added librarydata to tmodule
  390. to keep the library info stored for the module. In the future the
  391. objectfiles will also be stored to the tasmlibrarydata class
  392. * all getlabel/newasmsymbol and friends are moved to the new class
  393. Revision 1.12 2002/05/18 13:34:18 peter
  394. * readded missing revisions
  395. Revision 1.11 2002/05/16 19:46:45 carl
  396. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  397. + try to fix temp allocation (still in ifdef)
  398. + generic constructor calls
  399. + start of tassembler / tmodulebase class cleanup
  400. Revision 1.9 2002/05/12 16:53:15 peter
  401. * moved entry and exitcode to ncgutil and cgobj
  402. * foreach gets extra argument for passing local data to the
  403. iterator function
  404. * -CR checks also class typecasts at runtime by changing them
  405. into as
  406. * fixed compiler to cycle with the -CR option
  407. * fixed stabs with elf writer, finally the global variables can
  408. be watched
  409. * removed a lot of routines from cga unit and replaced them by
  410. calls to cgobj
  411. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  412. u32bit then the other is typecasted also to u32bit without giving
  413. a rangecheck warning/error.
  414. * fixed pascal calling method with reversing also the high tree in
  415. the parast, detected by tcalcst3 test
  416. Revision 1.8 2002/04/19 15:40:40 peter
  417. * optimize tfileposinfo writing, this reduces the ppu size with 20%
  418. }