ppu.pas 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Routines to read/write ppu files
  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 ppu;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. systems,globtype,constexp,cstreams;
  22. { Also write the ppu if only crc if done, this can be used with ppudump to
  23. see the differences between the intf and implementation }
  24. { define INTFPPU}
  25. {$ifdef Test_Double_checksum}
  26. var
  27. CRCFile : text;
  28. const
  29. CRC_array_Size = 200000;
  30. type
  31. tcrc_array = array[0..crc_array_size] of dword;
  32. pcrc_array = ^tcrc_array;
  33. {$endif Test_Double_checksum}
  34. const
  35. CurrentPPUVersion = 163;
  36. { buffer sizes }
  37. maxentrysize = 1024;
  38. ppubufsize = 16384;
  39. {ppu entries}
  40. mainentryid = 1;
  41. subentryid = 2;
  42. {special}
  43. iberror = 0;
  44. ibstartdefs = 248;
  45. ibenddefs = 249;
  46. ibstartsyms = 250;
  47. ibendsyms = 251;
  48. ibendinterface = 252;
  49. ibendimplementation = 253;
  50. // ibendbrowser = 254;
  51. ibend = 255;
  52. {general}
  53. ibmodulename = 1;
  54. ibsourcefiles = 2;
  55. ibloadunit = 3;
  56. ibinitunit = 4;
  57. iblinkunitofiles = 5;
  58. iblinkunitstaticlibs = 6;
  59. iblinkunitsharedlibs = 7;
  60. iblinkotherofiles = 8;
  61. iblinkotherstaticlibs = 9;
  62. iblinkothersharedlibs = 10;
  63. ibImportSymbols = 11;
  64. ibsymref = 12;
  65. ibdefref = 13;
  66. // ibendsymtablebrowser = 14;
  67. // ibbeginsymtablebrowser = 15;
  68. {$IFDEF MACRO_DIFF_HINT}
  69. ibusedmacros = 16;
  70. {$ENDIF}
  71. ibderefdata = 17;
  72. ibexportedmacros = 18;
  73. ibderefmap = 19;
  74. {syms}
  75. ibtypesym = 20;
  76. ibprocsym = 21;
  77. ibstaticvarsym = 22;
  78. ibconstsym = 23;
  79. ibenumsym = 24;
  80. // ibtypedconstsym = 25;
  81. ibabsolutevarsym = 26;
  82. ibpropertysym = 27;
  83. ibfieldvarsym = 28;
  84. ibunitsym = 29;
  85. iblabelsym = 30;
  86. ibsyssym = 31;
  87. ibnamespacesym = 32;
  88. iblocalvarsym = 33;
  89. ibparavarsym = 34;
  90. ibmacrosym = 35;
  91. {definitions}
  92. iborddef = 40;
  93. ibpointerdef = 41;
  94. ibarraydef = 42;
  95. ibprocdef = 43;
  96. ibshortstringdef = 44;
  97. ibrecorddef = 45;
  98. ibfiledef = 46;
  99. ibformaldef = 47;
  100. ibobjectdef = 48;
  101. ibenumdef = 49;
  102. ibsetdef = 50;
  103. ibprocvardef = 51;
  104. ibfloatdef = 52;
  105. ibclassrefdef = 53;
  106. iblongstringdef = 54;
  107. ibansistringdef = 55;
  108. ibwidestringdef = 56;
  109. ibvariantdef = 57;
  110. ibundefineddef = 58;
  111. ibunicodestringdef = 59;
  112. {implementation/ObjData}
  113. ibnodetree = 80;
  114. ibasmsymbols = 81;
  115. ibresources = 82;
  116. ibcreatedobjtypes = 83;
  117. ibwpofile = 84;
  118. ibmoduleoptions = 85;
  119. ibmainname = 90;
  120. ibsymtableoptions = 91;
  121. ibrecsymtableoptions = 91;
  122. { target-specific things }
  123. iblinkotherframeworks = 100;
  124. ibjvmnamespace = 101;
  125. { unit flags }
  126. uf_init = $000001; { unit has initialization section }
  127. uf_finalize = $000002; { unit has finalization section }
  128. uf_big_endian = $000004;
  129. //uf_has_browser = $000010;
  130. uf_in_library = $000020; { is the file in another file than <ppufile>.* ? }
  131. uf_smart_linked = $000040; { the ppu can be smartlinked }
  132. uf_static_linked = $000080; { the ppu can be linked static }
  133. uf_shared_linked = $000100; { the ppu can be linked shared }
  134. //uf_local_browser = $000200;
  135. uf_no_link = $000400; { unit has no .o generated, but can still have external linking! }
  136. uf_has_resourcestrings = $000800; { unit has resource string section }
  137. uf_little_endian = $001000;
  138. uf_release = $002000; { unit was compiled with -Ur option }
  139. uf_threadvars = $004000; { unit has threadvars }
  140. uf_fpu_emulation = $008000; { this unit was compiled with fpu emulation on }
  141. uf_has_stabs_debuginfo = $010000; { this unit has stabs debuginfo generated }
  142. uf_local_symtable = $020000; { this unit has a local symtable stored }
  143. uf_uses_variants = $040000; { this unit uses variants }
  144. uf_has_resourcefiles = $080000; { this unit has external resources (using $R directive)}
  145. uf_has_exports = $100000; { this module or a used unit has exports }
  146. uf_has_dwarf_debuginfo = $200000; { this unit has dwarf debuginfo generated }
  147. uf_wideinits = $400000; { this unit has winlike widestring typed constants }
  148. uf_classinits = $800000; { this unit has class constructors/destructors }
  149. uf_resstrinits = $1000000; { this unit has string consts referencing resourcestrings }
  150. uf_i8086_far_code = $2000000; { this unit uses an i8086 memory model with far code (i.e. medium, large or huge) }
  151. uf_i8086_far_data = $4000000; { this unit uses an i8086 memory model with far data (i.e. compact or large) }
  152. uf_i8086_huge_data = $8000000; { this unit uses an i8086 memory model with huge data (i.e. huge) }
  153. {$ifdef generic_cpu}
  154. { We need to use the correct size of aint and pint for
  155. the target CPU }
  156. const
  157. CpuAddrBitSize : array[tsystemcpu] of longint =
  158. (
  159. { 0 } 32 {'none'},
  160. { 1 } 32 {'i386'},
  161. { 2 } 32 {'m68k'},
  162. { 3 } 32 {'alpha'},
  163. { 4 } 32 {'powerpc'},
  164. { 5 } 32 {'sparc'},
  165. { 6 } 32 {'vis'},
  166. { 7 } 64 {'ia64'},
  167. { 8 } 64 {'x86_64'},
  168. { 9 } 32 {'mipseb'},
  169. { 10 } 32 {'arm'},
  170. { 11 } 64 {'powerpc64'},
  171. { 12 } 16 {'avr'},
  172. { 13 } 32 {'mipsel'},
  173. { 14 } 32 {'jvm'},
  174. { 15 } 16 {'i8086'}
  175. );
  176. CpuAluBitSize : array[tsystemcpu] of longint =
  177. (
  178. { 0 } 32 {'none'},
  179. { 1 } 32 {'i386'},
  180. { 2 } 32 {'m68k'},
  181. { 3 } 32 {'alpha'},
  182. { 4 } 32 {'powerpc'},
  183. { 5 } 32 {'sparc'},
  184. { 6 } 32 {'vis'},
  185. { 7 } 64 {'ia64'},
  186. { 8 } 64 {'x86_64'},
  187. { 9 } 32 {'mipseb'},
  188. { 10 } 32 {'arm'},
  189. { 11 } 64 {'powerpc64'},
  190. { 12 } 8 {'avr'},
  191. { 13 } 32 {'mipsel'},
  192. { 14 } 64 {'jvm'},
  193. { 15 } 16 {'i8086'}
  194. );
  195. {$endif generic_cpu}
  196. type
  197. { bestreal is defined based on the target architecture }
  198. ppureal=bestreal;
  199. tppuerror=(ppuentrytoobig,ppuentryerror);
  200. tppuheader=record
  201. id : array[1..3] of char; { = 'PPU' }
  202. ver : array[1..3] of char;
  203. compiler : word;
  204. cpu : word;
  205. target : word;
  206. flags : longint;
  207. size : longint; { size of the ppufile without header }
  208. checksum : cardinal; { checksum for this ppufile }
  209. interface_checksum : cardinal;
  210. deflistsize,
  211. symlistsize : longint;
  212. indirect_checksum: cardinal;
  213. end;
  214. tppuentry=packed record
  215. size : longint;
  216. id : byte;
  217. nr : byte;
  218. end;
  219. { tppufile }
  220. tppufile=class
  221. private
  222. f : TCCustomFileStream;
  223. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  224. fname : string;
  225. fsize : integer;
  226. {$ifdef Test_Double_checksum}
  227. public
  228. crcindex,
  229. crc_index,
  230. crcindex2,
  231. crc_index2 : cardinal;
  232. crc_test,
  233. crc_test2 : pcrc_array;
  234. private
  235. {$endif def Test_Double_checksum}
  236. buf : pchar;
  237. bufstart,
  238. bufsize,
  239. bufidx : integer;
  240. entrybufstart,
  241. entrystart,
  242. entryidx : integer;
  243. entry : tppuentry;
  244. closed,
  245. tempclosed : boolean;
  246. closepos : integer;
  247. public
  248. entrytyp : byte;
  249. header : tppuheader;
  250. size : integer;
  251. change_endian : boolean; { Used in ppudump util }
  252. { crc for the entire unit }
  253. crc,
  254. { crc for the interface definitions in this unit }
  255. interface_crc,
  256. { crc of all object/class definitions in the interface of this unit, xor'ed
  257. by the crc's of all object/class definitions in the interfaces of units
  258. used by this unit. Reason: see mantis #13840 }
  259. indirect_crc : cardinal;
  260. error,
  261. {$ifdef generic_cpu}
  262. has_more,
  263. {$endif not generic_cpu}
  264. do_crc,
  265. do_interface_crc,
  266. do_indirect_crc : boolean;
  267. crc_only : boolean; { used to calculate interface_crc before implementation }
  268. constructor Create(const fn:string);
  269. destructor Destroy;override;
  270. procedure flush;
  271. procedure closefile;
  272. function CheckPPUId:boolean;
  273. function GetPPUVersion:integer;
  274. procedure NewHeader;
  275. procedure NewEntry;
  276. {read}
  277. function openfile:boolean;
  278. procedure reloadbuf;
  279. procedure readdata(out b;len:integer);
  280. procedure skipdata(len:integer);
  281. function readentry:byte;
  282. function EndOfEntry:boolean;
  283. function entrysize:longint;
  284. function entryleft:longint;
  285. procedure getdatabuf(out b;len:integer;out res:integer);
  286. procedure getdata(out b;len:integer);
  287. function getbyte:byte;
  288. function getword:word;
  289. function getdword:dword;
  290. function getlongint:longint;
  291. function getint64:int64;
  292. function getqword:qword;
  293. function getaint:aint;
  294. function getasizeint:asizeint;
  295. function getaword:aword;
  296. function getreal:ppureal;
  297. function getrealsize(sizeofreal : longint):ppureal;
  298. function getstring:string;
  299. function getansistring:ansistring;
  300. procedure getnormalset(out b);
  301. procedure getsmallset(out b);
  302. function skipuntilentry(untilb:byte):boolean;
  303. {write}
  304. function createfile:boolean;
  305. procedure writeheader;
  306. procedure writebuf;
  307. procedure writedata(const b;len:integer);
  308. procedure writeentry(ibnr:byte);
  309. procedure putdata(const b;len:integer);
  310. procedure putbyte(b:byte);
  311. procedure putword(w:word);
  312. procedure putdword(w:dword);
  313. procedure putlongint(l:longint);
  314. procedure putint64(i:int64);
  315. procedure putqword(q:qword);
  316. procedure putaint(i:aint);
  317. procedure putasizeint(i:asizeint);
  318. procedure putaword(i:aword);
  319. procedure putreal(d:ppureal);
  320. procedure putstring(const s:string);
  321. procedure putansistring(const s:ansistring);
  322. procedure putnormalset(const b);
  323. procedure putsmallset(const b);
  324. procedure tempclose; // MG: not used, obsolete?
  325. function tempopen:boolean; // MG: not used, obsolete?
  326. end;
  327. implementation
  328. uses
  329. {$ifdef Test_Double_checksum}
  330. comphook,
  331. {$endif def Test_Double_checksum}
  332. fpccrc,
  333. cutils;
  334. function swapendian_ppureal(d:ppureal):ppureal;
  335. type ppureal_bytes=array[0..sizeof(d)-1] of byte;
  336. var i:0..sizeof(d)-1;
  337. begin
  338. for i:=low(ppureal_bytes) to high(ppureal_bytes) do
  339. ppureal_bytes(swapendian_ppureal)[i]:=ppureal_bytes(d)[high(ppureal_bytes)-i];
  340. end;
  341. {*****************************************************************************
  342. TPPUFile
  343. *****************************************************************************}
  344. constructor tppufile.Create(const fn:string);
  345. begin
  346. fname:=fn;
  347. change_endian:=false;
  348. crc_only:=false;
  349. Mode:=0;
  350. NewHeader;
  351. Error:=false;
  352. closed:=true;
  353. tempclosed:=false;
  354. getmem(buf,ppubufsize);
  355. end;
  356. destructor tppufile.destroy;
  357. begin
  358. closefile;
  359. if assigned(buf) then
  360. freemem(buf,ppubufsize);
  361. end;
  362. procedure tppufile.flush;
  363. begin
  364. if Mode=2 then
  365. writebuf;
  366. end;
  367. procedure tppufile.closefile;
  368. begin
  369. {$ifdef Test_Double_checksum}
  370. if mode=2 then
  371. begin
  372. if assigned(crc_test) then
  373. dispose(crc_test);
  374. if assigned(crc_test2) then
  375. dispose(crc_test2);
  376. end;
  377. {$endif Test_Double_checksum}
  378. if Mode<>0 then
  379. begin
  380. Flush;
  381. f.Free;
  382. Mode:=0;
  383. closed:=true;
  384. end;
  385. end;
  386. function tppufile.CheckPPUId:boolean;
  387. begin
  388. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  389. end;
  390. function tppufile.GetPPUVersion:integer;
  391. var
  392. l : integer;
  393. code : integer;
  394. begin
  395. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  396. if code=0 then
  397. GetPPUVersion:=l
  398. else
  399. GetPPUVersion:=0;
  400. end;
  401. procedure tppufile.NewHeader;
  402. var
  403. s : string;
  404. begin
  405. fillchar(header,sizeof(tppuheader),0);
  406. str(currentppuversion,s);
  407. while length(s)<3 do
  408. s:='0'+s;
  409. with header do
  410. begin
  411. Id[1]:='P';
  412. Id[2]:='P';
  413. Id[3]:='U';
  414. Ver[1]:=s[1];
  415. Ver[2]:=s[2];
  416. Ver[3]:=s[3];
  417. end;
  418. end;
  419. {*****************************************************************************
  420. TPPUFile Reading
  421. *****************************************************************************}
  422. function tppufile.openfile:boolean;
  423. var
  424. i : integer;
  425. begin
  426. openfile:=false;
  427. try
  428. f:=CFileStreamClass.Create(fname,fmOpenRead)
  429. except
  430. exit;
  431. end;
  432. closed:=false;
  433. {read ppuheader}
  434. fsize:=f.Size;
  435. if fsize<sizeof(tppuheader) then
  436. exit;
  437. i:=f.Read(header,sizeof(tppuheader));
  438. { The header is always stored in little endian order }
  439. { therefore swap if on a big endian machine }
  440. {$IFDEF ENDIAN_BIG}
  441. header.compiler := swapendian(header.compiler);
  442. header.cpu := swapendian(header.cpu);
  443. header.target := swapendian(header.target);
  444. header.flags := swapendian(header.flags);
  445. header.size := swapendian(header.size);
  446. header.checksum := swapendian(header.checksum);
  447. header.interface_checksum := swapendian(header.interface_checksum);
  448. header.indirect_checksum := swapendian(header.indirect_checksum);
  449. header.deflistsize:=swapendian(header.deflistsize);
  450. header.symlistsize:=swapendian(header.symlistsize);
  451. {$ENDIF}
  452. { the PPU DATA is stored in native order }
  453. if (header.flags and uf_big_endian) = uf_big_endian then
  454. Begin
  455. {$IFDEF ENDIAN_LITTLE}
  456. change_endian := TRUE;
  457. {$ELSE}
  458. change_endian := FALSE;
  459. {$ENDIF}
  460. End
  461. else if (header.flags and uf_little_endian) = uf_little_endian then
  462. Begin
  463. {$IFDEF ENDIAN_BIG}
  464. change_endian := TRUE;
  465. {$ELSE}
  466. change_endian := FALSE;
  467. {$ENDIF}
  468. End;
  469. {reset buffer}
  470. bufstart:=i;
  471. bufsize:=0;
  472. bufidx:=0;
  473. Mode:=1;
  474. FillChar(entry,sizeof(tppuentry),0);
  475. entryidx:=0;
  476. entrystart:=0;
  477. entrybufstart:=0;
  478. Error:=false;
  479. openfile:=true;
  480. end;
  481. procedure tppufile.reloadbuf;
  482. begin
  483. inc(bufstart,bufsize);
  484. bufsize:=f.Read(buf^,ppubufsize);
  485. bufidx:=0;
  486. end;
  487. procedure tppufile.readdata(out b;len:integer);
  488. var
  489. p,pbuf : pchar;
  490. left : integer;
  491. begin
  492. p:=pchar(@b);
  493. pbuf:=@buf[bufidx];
  494. repeat
  495. left:=bufsize-bufidx;
  496. if len<left then
  497. break;
  498. move(pbuf^,p^,left);
  499. dec(len,left);
  500. inc(p,left);
  501. reloadbuf;
  502. pbuf:=@buf[bufidx];
  503. if bufsize=0 then
  504. exit;
  505. until false;
  506. move(pbuf^,p^,len);
  507. inc(bufidx,len);
  508. end;
  509. procedure tppufile.skipdata(len:integer);
  510. var
  511. left : integer;
  512. begin
  513. while len>0 do
  514. begin
  515. left:=bufsize-bufidx;
  516. if len>left then
  517. begin
  518. dec(len,left);
  519. reloadbuf;
  520. if bufsize=0 then
  521. exit;
  522. end
  523. else
  524. begin
  525. inc(bufidx,len);
  526. exit;
  527. end;
  528. end;
  529. end;
  530. function tppufile.readentry:byte;
  531. begin
  532. if entryidx<entry.size then
  533. begin
  534. {$ifdef generic_cpu}
  535. has_more:=true;
  536. {$endif not generic_cpu}
  537. skipdata(entry.size-entryidx);
  538. end;
  539. readdata(entry,sizeof(tppuentry));
  540. if change_endian then
  541. entry.size:=swapendian(entry.size);
  542. entrystart:=bufstart+bufidx;
  543. entryidx:=0;
  544. {$ifdef generic_cpu}
  545. has_more:=false;
  546. {$endif not generic_cpu}
  547. if not(entry.id in [mainentryid,subentryid]) then
  548. begin
  549. readentry:=iberror;
  550. error:=true;
  551. exit;
  552. end;
  553. readentry:=entry.nr;
  554. end;
  555. function tppufile.endofentry:boolean;
  556. begin
  557. {$ifdef generic_cpu}
  558. endofentry:=(entryidx=entry.size);
  559. {$else not generic_cpu}
  560. endofentry:=(entryidx>=entry.size);
  561. {$endif not generic_cpu}
  562. end;
  563. function tppufile.entrysize:longint;
  564. begin
  565. entrysize:=entry.size;
  566. end;
  567. function tppufile.entryleft:longint;
  568. begin
  569. entryleft:=entry.size-entryidx;
  570. end;
  571. procedure tppufile.getdatabuf(out b;len:integer;out res:integer);
  572. begin
  573. if entryidx+len>entry.size then
  574. res:=entry.size-entryidx
  575. else
  576. res:=len;
  577. readdata(b,res);
  578. inc(entryidx,res);
  579. end;
  580. procedure tppufile.getdata(out b;len:integer);
  581. begin
  582. if entryidx+len>entry.size then
  583. begin
  584. error:=true;
  585. exit;
  586. end;
  587. readdata(b,len);
  588. inc(entryidx,len);
  589. end;
  590. function tppufile.getbyte:byte;
  591. begin
  592. if entryidx+1>entry.size then
  593. begin
  594. error:=true;
  595. result:=0;
  596. exit;
  597. end;
  598. if bufsize-bufidx>=1 then
  599. begin
  600. result:=pbyte(@buf[bufidx])^;
  601. inc(bufidx);
  602. end
  603. else
  604. readdata(result,1);
  605. inc(entryidx);
  606. end;
  607. function tppufile.getword:word;
  608. begin
  609. if entryidx+2>entry.size then
  610. begin
  611. error:=true;
  612. result:=0;
  613. exit;
  614. end;
  615. if bufsize-bufidx>=sizeof(word) then
  616. begin
  617. result:=Unaligned(pword(@buf[bufidx])^);
  618. inc(bufidx,sizeof(word));
  619. end
  620. else
  621. readdata(result,sizeof(word));
  622. if change_endian then
  623. result:=swapendian(result);
  624. inc(entryidx,2);
  625. end;
  626. function tppufile.getlongint:longint;
  627. begin
  628. if entryidx+4>entry.size then
  629. begin
  630. error:=true;
  631. result:=0;
  632. exit;
  633. end;
  634. if bufsize-bufidx>=sizeof(longint) then
  635. begin
  636. result:=Unaligned(plongint(@buf[bufidx])^);
  637. inc(bufidx,sizeof(longint));
  638. end
  639. else
  640. readdata(result,sizeof(longint));
  641. if change_endian then
  642. result:=swapendian(result);
  643. inc(entryidx,4);
  644. end;
  645. function tppufile.getdword:dword;
  646. begin
  647. if entryidx+4>entry.size then
  648. begin
  649. error:=true;
  650. result:=0;
  651. exit;
  652. end;
  653. if bufsize-bufidx>=sizeof(dword) then
  654. begin
  655. result:=Unaligned(plongint(@buf[bufidx])^);
  656. inc(bufidx,sizeof(longint));
  657. end
  658. else
  659. readdata(result,sizeof(dword));
  660. if change_endian then
  661. result:=swapendian(result);
  662. inc(entryidx,4);
  663. end;
  664. function tppufile.getint64:int64;
  665. begin
  666. if entryidx+8>entry.size then
  667. begin
  668. error:=true;
  669. result:=0;
  670. exit;
  671. end;
  672. if bufsize-bufidx>=sizeof(int64) then
  673. begin
  674. result:=Unaligned(pint64(@buf[bufidx])^);
  675. inc(bufidx,sizeof(int64));
  676. end
  677. else
  678. readdata(result,sizeof(int64));
  679. if change_endian then
  680. result:=swapendian(result);
  681. inc(entryidx,8);
  682. end;
  683. function tppufile.getqword:qword;
  684. begin
  685. if entryidx+8>entry.size then
  686. begin
  687. error:=true;
  688. result:=0;
  689. exit;
  690. end;
  691. if bufsize-bufidx>=sizeof(qword) then
  692. begin
  693. result:=Unaligned(pqword(@buf[bufidx])^);
  694. inc(bufidx,sizeof(qword));
  695. end
  696. else
  697. readdata(result,sizeof(qword));
  698. if change_endian then
  699. result:=swapendian(result);
  700. inc(entryidx,8);
  701. end;
  702. function tppufile.getaint:aint;
  703. begin
  704. {$ifdef generic_cpu}
  705. if CpuAluBitSize[tsystemcpu(header.cpu)]=64 then
  706. result:=getint64
  707. else if CpuAluBitSize[tsystemcpu(header.cpu)]=32 then
  708. result:=getlongint
  709. else if CpuAluBitSize[tsystemcpu(header.cpu)]=16 then
  710. result:=smallint(getword)
  711. else if CpuAluBitSize[tsystemcpu(header.cpu)]=8 then
  712. result:=shortint(getbyte)
  713. else
  714. begin
  715. error:=true;
  716. result:=0;
  717. end;
  718. {$else not generic_cpu}
  719. case sizeof(aint) of
  720. 8: result:=getint64;
  721. 4: result:=getlongint;
  722. 2: result:=smallint(getword);
  723. 1: result:=shortint(getbyte);
  724. end;
  725. {$endif not generic_cpu}
  726. end;
  727. function tppufile.getasizeint:asizeint;
  728. begin
  729. {$ifdef generic_cpu}
  730. if CpuAddrBitSize[tsystemcpu(header.cpu)]=64 then
  731. result:=getint64
  732. else if CpuAddrBitSize[tsystemcpu(header.cpu)]=32 then
  733. result:=getlongint
  734. else if CpuAddrBitSize[tsystemcpu(header.cpu)]=16 then
  735. result:=smallint(getword)
  736. else
  737. begin
  738. error:=true;
  739. result:=0;
  740. end;
  741. {$else not generic_cpu}
  742. {$if defined(cpu64bitaddr)}
  743. result:=getint64;
  744. {$elseif defined(cpu32bitaddr)}
  745. result:=getlongint;
  746. {$elseif defined(cpu16bitaddr)}
  747. result:=getword;
  748. {$endif}
  749. {$endif not generic_cpu}
  750. end;
  751. function tppufile.getaword:aword;
  752. begin
  753. {$ifdef generic_cpu}
  754. if CpuAluBitSize[tsystemcpu(header.cpu)]=64 then
  755. result:=getqword
  756. else if CpuAluBitSize[tsystemcpu(header.cpu)]=32 then
  757. result:=getdword
  758. else if CpuAluBitSize[tsystemcpu(header.cpu)]=16 then
  759. result:=getword
  760. else if CpuAluBitSize[tsystemcpu(header.cpu)]=8 then
  761. result:=getbyte
  762. else
  763. begin
  764. error:=true;
  765. result:=0;
  766. end;
  767. {$else not generic_cpu}
  768. {$ifdef cpu64bitalu}
  769. result:=getqword;
  770. {$else cpu64bitalu}
  771. result:=getdword;
  772. {$endif cpu64bitalu}
  773. {$endif not generic_cpu}
  774. end;
  775. function tppufile.getrealsize(sizeofreal : longint):ppureal;
  776. var
  777. e : ppureal;
  778. d : double;
  779. s : single;
  780. begin
  781. if sizeofreal=sizeof(e) then
  782. begin
  783. if entryidx+sizeof(e)>entry.size then
  784. begin
  785. error:=true;
  786. result:=0;
  787. exit;
  788. end;
  789. readdata(e,sizeof(e));
  790. if change_endian then
  791. result:=swapendian_ppureal(e)
  792. else
  793. result:=e;
  794. inc(entryidx,sizeof(e));
  795. exit;
  796. end;
  797. if sizeofreal=sizeof(d) then
  798. begin
  799. if entryidx+sizeof(d)>entry.size then
  800. begin
  801. error:=true;
  802. result:=0;
  803. exit;
  804. end;
  805. readdata(d,sizeof(d));
  806. if change_endian then
  807. result:=swapendian(pqword(@d)^)
  808. else
  809. result:=d;
  810. inc(entryidx,sizeof(d));
  811. result:=d;
  812. exit;
  813. end;
  814. if sizeofreal=sizeof(s) then
  815. begin
  816. if entryidx+sizeof(s)>entry.size then
  817. begin
  818. error:=true;
  819. result:=0;
  820. exit;
  821. end;
  822. readdata(s,sizeof(s));
  823. if change_endian then
  824. result:=swapendian(pdword(@s)^)
  825. else
  826. result:=s;
  827. inc(entryidx,sizeof(s));
  828. result:=s;
  829. exit;
  830. end;
  831. error:=true;
  832. result:=0.0;
  833. end;
  834. function tppufile.getreal:ppureal;
  835. var
  836. d : ppureal;
  837. hd : double;
  838. begin
  839. if target_info.system=system_x86_64_win64 then
  840. begin
  841. hd:=getrealsize(sizeof(hd));
  842. getreal:=hd;
  843. end
  844. else
  845. begin
  846. d:=getrealsize(sizeof(d));
  847. getreal:=d;
  848. end;
  849. end;
  850. function tppufile.getstring:string;
  851. begin
  852. result[0]:=chr(getbyte);
  853. if entryidx+length(result)>entry.size then
  854. begin
  855. error:=true;
  856. exit;
  857. end;
  858. ReadData(result[1],length(result));
  859. inc(entryidx,length(result));
  860. end;
  861. function tppufile.getansistring:ansistring;
  862. var
  863. len: longint;
  864. begin
  865. len:=getlongint;
  866. if entryidx+len>entry.size then
  867. begin
  868. error:=true;
  869. exit;
  870. end;
  871. setlength(result,len);
  872. if len>0 then
  873. getdata(result[1],len);
  874. end;
  875. procedure tppufile.getsmallset(out b);
  876. var
  877. i : longint;
  878. begin
  879. getdata(b,4);
  880. if change_endian then
  881. for i:=0 to 3 do
  882. Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
  883. end;
  884. procedure tppufile.getnormalset(out b);
  885. var
  886. i : longint;
  887. begin
  888. getdata(b,32);
  889. if change_endian then
  890. for i:=0 to 31 do
  891. Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
  892. end;
  893. function tppufile.skipuntilentry(untilb:byte):boolean;
  894. var
  895. b : byte;
  896. begin
  897. repeat
  898. b:=readentry;
  899. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  900. skipuntilentry:=(b=untilb);
  901. end;
  902. {*****************************************************************************
  903. TPPUFile Writing
  904. *****************************************************************************}
  905. function tppufile.createfile:boolean;
  906. var
  907. ok: boolean;
  908. begin
  909. createfile:=false;
  910. {$ifdef INTFPPU}
  911. if crc_only then
  912. begin
  913. fname:=fname+'.intf';
  914. crc_only:=false;
  915. end;
  916. {$endif}
  917. if not crc_only then
  918. begin
  919. {$ifdef MACOS}
  920. {FPas is FreePascal's creator code on MacOS. See systems/mac_crea.txt}
  921. SetDefaultMacOSCreator('FPas');
  922. SetDefaultMacOSFiletype('FPPU');
  923. {$endif}
  924. ok:=false;
  925. try
  926. f:=CFileStreamClass.Create(fname,fmCreate);
  927. ok:=true;
  928. except
  929. end;
  930. {$ifdef MACOS}
  931. SetDefaultMacOSCreator('MPS ');
  932. SetDefaultMacOSFiletype('TEXT');
  933. {$endif}
  934. if not ok then
  935. exit;
  936. Mode:=2;
  937. {write header for sure}
  938. f.Write(header,sizeof(tppuheader));
  939. end;
  940. bufsize:=ppubufsize;
  941. bufstart:=sizeof(tppuheader);
  942. bufidx:=0;
  943. {reset}
  944. crc:=0;
  945. interface_crc:=0;
  946. indirect_crc:=0;
  947. do_interface_crc:=true;
  948. do_indirect_crc:=false;
  949. Error:=false;
  950. do_crc:=true;
  951. size:=0;
  952. entrytyp:=mainentryid;
  953. {start}
  954. NewEntry;
  955. createfile:=true;
  956. end;
  957. procedure tppufile.writeheader;
  958. var
  959. opos : integer;
  960. begin
  961. if crc_only then
  962. exit;
  963. { flush buffer }
  964. writebuf;
  965. { update size (w/o header!) in the header }
  966. header.size:=bufstart-sizeof(tppuheader);
  967. { set the endian flag }
  968. {$ifndef FPC_BIG_ENDIAN}
  969. header.flags := header.flags or uf_little_endian;
  970. {$else not FPC_BIG_ENDIAN}
  971. header.flags := header.flags or uf_big_endian;
  972. { Now swap the header in the correct endian (always little endian) }
  973. header.compiler := swapendian(header.compiler);
  974. header.cpu := swapendian(header.cpu);
  975. header.target := swapendian(header.target);
  976. header.flags := swapendian(header.flags);
  977. header.size := swapendian(header.size);
  978. header.checksum := swapendian(header.checksum);
  979. header.interface_checksum := swapendian(header.interface_checksum);
  980. header.indirect_checksum := swapendian(header.indirect_checksum);
  981. header.deflistsize:=swapendian(header.deflistsize);
  982. header.symlistsize:=swapendian(header.symlistsize);
  983. {$endif not FPC_BIG_ENDIAN}
  984. { write header and restore filepos after it }
  985. opos:=f.Position;
  986. f.Position:=0;
  987. f.Write(header,sizeof(tppuheader));
  988. f.Position:=opos;
  989. end;
  990. procedure tppufile.writebuf;
  991. begin
  992. if not crc_only and
  993. (bufidx <> 0) then
  994. f.Write(buf^,bufidx);
  995. inc(bufstart,bufidx);
  996. bufidx:=0;
  997. end;
  998. procedure tppufile.writedata(const b;len:integer);
  999. var
  1000. p : pchar;
  1001. left,
  1002. idx : integer;
  1003. begin
  1004. if crc_only then
  1005. exit;
  1006. p:=pchar(@b);
  1007. idx:=0;
  1008. while len>0 do
  1009. begin
  1010. left:=bufsize-bufidx;
  1011. if len>left then
  1012. begin
  1013. move(p[idx],buf[bufidx],left);
  1014. dec(len,left);
  1015. inc(idx,left);
  1016. inc(bufidx,left);
  1017. writebuf;
  1018. end
  1019. else
  1020. begin
  1021. move(p[idx],buf[bufidx],len);
  1022. inc(bufidx,len);
  1023. exit;
  1024. end;
  1025. end;
  1026. end;
  1027. procedure tppufile.NewEntry;
  1028. begin
  1029. with entry do
  1030. begin
  1031. id:=entrytyp;
  1032. nr:=ibend;
  1033. size:=0;
  1034. end;
  1035. {Reset Entry State}
  1036. entryidx:=0;
  1037. entrybufstart:=bufstart;
  1038. entrystart:=bufstart+bufidx;
  1039. {Alloc in buffer}
  1040. writedata(entry,sizeof(tppuentry));
  1041. end;
  1042. procedure tppufile.writeentry(ibnr:byte);
  1043. var
  1044. opos : integer;
  1045. begin
  1046. {create entry}
  1047. entry.id:=entrytyp;
  1048. entry.nr:=ibnr;
  1049. entry.size:=entryidx;
  1050. {it's already been sent to disk ?}
  1051. if entrybufstart<>bufstart then
  1052. begin
  1053. if not crc_only then
  1054. begin
  1055. {flush to be sure}
  1056. WriteBuf;
  1057. {write entry}
  1058. opos:=f.Position;
  1059. f.Position:=entrystart;
  1060. f.write(entry,sizeof(tppuentry));
  1061. f.Position:=opos;
  1062. end;
  1063. entrybufstart:=bufstart;
  1064. end
  1065. else
  1066. move(entry,buf[entrystart-bufstart],sizeof(entry));
  1067. {Add New Entry, which is ibend by default}
  1068. entrystart:=bufstart+bufidx; {next entry position}
  1069. NewEntry;
  1070. end;
  1071. procedure tppufile.putdata(const b;len:integer);
  1072. begin
  1073. if do_crc then
  1074. begin
  1075. crc:=UpdateCrc32(crc,b,len);
  1076. {$ifdef Test_Double_checksum}
  1077. if crc_only then
  1078. begin
  1079. crc_test2^[crc_index2]:=crc;
  1080. {$ifdef Test_Double_checksum_write}
  1081. Writeln(CRCFile,crc);
  1082. {$endif Test_Double_checksum_write}
  1083. if crc_index2<crc_array_size then
  1084. inc(crc_index2);
  1085. end
  1086. else
  1087. begin
  1088. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  1089. (crc_test2^[crcindex2]<>crc) then
  1090. Do_comment(V_Note,'impl CRC changed');
  1091. {$ifdef Test_Double_checksum_write}
  1092. Writeln(CRCFile,crc);
  1093. {$endif Test_Double_checksum_write}
  1094. inc(crcindex2);
  1095. end;
  1096. {$endif def Test_Double_checksum}
  1097. if do_interface_crc then
  1098. begin
  1099. interface_crc:=UpdateCrc32(interface_crc,b,len);
  1100. {$ifdef Test_Double_checksum}
  1101. if crc_only then
  1102. begin
  1103. crc_test^[crc_index]:=interface_crc;
  1104. {$ifdef Test_Double_checksum_write}
  1105. Writeln(CRCFile,interface_crc);
  1106. {$endif Test_Double_checksum_write}
  1107. if crc_index<crc_array_size then
  1108. inc(crc_index);
  1109. end
  1110. else
  1111. begin
  1112. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  1113. (crc_test^[crcindex]<>interface_crc) then
  1114. Do_comment(V_Warning,'CRC changed');
  1115. {$ifdef Test_Double_checksum_write}
  1116. Writeln(CRCFile,interface_crc);
  1117. {$endif Test_Double_checksum_write}
  1118. inc(crcindex);
  1119. end;
  1120. {$endif def Test_Double_checksum}
  1121. { indirect crc must only be calculated for the interface; changes
  1122. to a class in the implementation cannot require another unit to
  1123. be recompiled }
  1124. if do_indirect_crc then
  1125. indirect_crc:=UpdateCrc32(indirect_crc,b,len);
  1126. end;
  1127. end;
  1128. if not crc_only then
  1129. writedata(b,len);
  1130. inc(entryidx,len);
  1131. end;
  1132. procedure tppufile.putbyte(b:byte);
  1133. begin
  1134. putdata(b,1);
  1135. end;
  1136. procedure tppufile.putword(w:word);
  1137. begin
  1138. putdata(w,2);
  1139. end;
  1140. procedure tppufile.putdword(w:dword);
  1141. begin
  1142. putdata(w,4);
  1143. end;
  1144. procedure tppufile.putlongint(l:longint);
  1145. begin
  1146. putdata(l,4);
  1147. end;
  1148. procedure tppufile.putint64(i:int64);
  1149. begin
  1150. putdata(i,8);
  1151. end;
  1152. procedure tppufile.putqword(q:qword);
  1153. begin
  1154. putdata(q,sizeof(qword));
  1155. end;
  1156. procedure tppufile.putaint(i:aint);
  1157. begin
  1158. putdata(i,sizeof(aint));
  1159. end;
  1160. procedure tppufile.putasizeint(i: asizeint);
  1161. begin
  1162. putdata(i,sizeof(asizeint));
  1163. end;
  1164. procedure tppufile.putaword(i:aword);
  1165. begin
  1166. putdata(i,sizeof(aword));
  1167. end;
  1168. procedure tppufile.putreal(d:ppureal);
  1169. var
  1170. hd : double;
  1171. begin
  1172. if target_info.system=system_x86_64_win64 then
  1173. begin
  1174. hd:=d;
  1175. putdata(hd,sizeof(hd));
  1176. end
  1177. else
  1178. putdata(d,sizeof(ppureal));
  1179. end;
  1180. procedure tppufile.putstring(const s:string);
  1181. begin
  1182. putdata(s,length(s)+1);
  1183. end;
  1184. procedure tppufile.putansistring(const s:ansistring);
  1185. var
  1186. len: longint;
  1187. begin
  1188. len:=length(s);
  1189. putlongint(len);
  1190. if len>0 then
  1191. putdata(s[1],len);
  1192. end;
  1193. procedure tppufile.putsmallset(const b);
  1194. var
  1195. l : longint;
  1196. begin
  1197. l:=longint(b);
  1198. putlongint(l);
  1199. end;
  1200. procedure tppufile.putnormalset(const b);
  1201. begin
  1202. putdata(b,32);
  1203. end;
  1204. procedure tppufile.tempclose;
  1205. begin
  1206. if not closed then
  1207. begin
  1208. closepos:=f.Position;
  1209. f.Free;
  1210. f:=nil;
  1211. closed:=true;
  1212. tempclosed:=true;
  1213. end;
  1214. end;
  1215. function tppufile.tempopen:boolean;
  1216. begin
  1217. tempopen:=false;
  1218. if not closed or not tempclosed then
  1219. exit;
  1220. { MG: not sure, if this is correct
  1221. f.position:=0;
  1222. No, f was freed in tempclose above, we need to
  1223. recreate it. PM 2011/06/06 }
  1224. try
  1225. f:=CFileStreamClass.Create(fname,fmOpenRead);
  1226. except
  1227. exit;
  1228. end;
  1229. closed:=false;
  1230. tempclosed:=false;
  1231. { restore state }
  1232. f.Position:=closepos;
  1233. tempopen:=true;
  1234. end;
  1235. end.