ppu.pas 23 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099
  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. globtype;
  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 longint;
  32. pcrc_array = ^tcrc_array;
  33. {$endif Test_Double_checksum}
  34. const
  35. CurrentPPUVersion=77;
  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. // ibrttisym = 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. {implementation/ObjData}
  112. ibnodetree = 80;
  113. ibasmsymbols = 81;
  114. { unit flags }
  115. uf_init = $1;
  116. uf_finalize = $2;
  117. uf_big_endian = $4;
  118. // uf_has_browser = $10;
  119. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  120. uf_smart_linked = $40; { the ppu can be smartlinked }
  121. uf_static_linked = $80; { the ppu can be linked static }
  122. uf_shared_linked = $100; { the ppu can be linked shared }
  123. // uf_local_browser = $200;
  124. uf_no_link = $400; { unit has no .o generated, but can still have
  125. external linking! }
  126. uf_has_resourcestrings = $800; { unit has resource string section }
  127. uf_little_endian = $1000;
  128. uf_release = $2000; { unit was compiled with -Ur option }
  129. uf_threadvars = $4000; { unit has threadvars }
  130. uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
  131. uf_has_debuginfo = $10000; { this unit has debuginfo generated }
  132. uf_local_symtable = $20000; { this unit has a local symtable stored }
  133. uf_uses_variants = $40000; { this unit uses variants }
  134. uf_has_resourcefiles = $80000; { this unit has external resources (using $R directive)}
  135. uf_has_exports = $100000; { this module or a used unit has exports }
  136. type
  137. ppureal=extended;
  138. tppuerror=(ppuentrytoobig,ppuentryerror);
  139. tppuheader=record
  140. id : array[1..3] of char; { = 'PPU' }
  141. ver : array[1..3] of char;
  142. compiler : word;
  143. cpu : word;
  144. target : word;
  145. flags : longint;
  146. size : longint; { size of the ppufile without header }
  147. checksum : cardinal; { checksum for this ppufile }
  148. interface_checksum : cardinal;
  149. deflistsize,
  150. symlistsize : longint;
  151. future : array[0..0] of longint;
  152. end;
  153. tppuentry=packed record
  154. size : longint;
  155. id : byte;
  156. nr : byte;
  157. end;
  158. tppufile=class
  159. private
  160. f : file;
  161. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  162. fname : string;
  163. fsize : integer;
  164. {$ifdef Test_Double_checksum}
  165. public
  166. crcindex,
  167. crc_index,
  168. crcindex2,
  169. crc_index2 : cardinal;
  170. crc_test,
  171. crc_test2 : pcrc_array;
  172. private
  173. {$endif def Test_Double_checksum}
  174. change_endian : boolean;
  175. buf : pchar;
  176. bufstart,
  177. bufsize,
  178. bufidx : integer;
  179. entrybufstart,
  180. entrystart,
  181. entryidx : integer;
  182. entry : tppuentry;
  183. closed,
  184. tempclosed : boolean;
  185. closepos : integer;
  186. public
  187. entrytyp : byte;
  188. header : tppuheader;
  189. size : integer;
  190. crc,
  191. interface_crc : cardinal;
  192. error,
  193. do_crc,
  194. do_interface_crc : boolean;
  195. crc_only : boolean; { used to calculate interface_crc before implementation }
  196. constructor Create(const fn:string);
  197. destructor Destroy;override;
  198. procedure flush;
  199. procedure closefile;
  200. function CheckPPUId:boolean;
  201. function GetPPUVersion:integer;
  202. procedure NewHeader;
  203. procedure NewEntry;
  204. {read}
  205. function openfile:boolean;
  206. procedure reloadbuf;
  207. procedure readdata(var b;len:integer);
  208. procedure skipdata(len:integer);
  209. function readentry:byte;
  210. function EndOfEntry:boolean;
  211. function entrysize:longint;
  212. procedure getdatabuf(var b;len:integer;var res:integer);
  213. procedure getdata(var b;len:integer);
  214. function getbyte:byte;
  215. function getword:word;
  216. function getlongint:longint;
  217. function getint64:int64;
  218. function getaint:aint;
  219. function getreal:ppureal;
  220. function getstring:string;
  221. procedure getnormalset(var b);
  222. procedure getsmallset(var b);
  223. function skipuntilentry(untilb:byte):boolean;
  224. {write}
  225. function createfile:boolean;
  226. procedure writeheader;
  227. procedure writebuf;
  228. procedure writedata(const b;len:integer);
  229. procedure writeentry(ibnr:byte);
  230. procedure putdata(const b;len:integer);
  231. procedure putbyte(b:byte);
  232. procedure putword(w:word);
  233. procedure putlongint(l:longint);
  234. procedure putint64(i:int64);
  235. procedure putaint(i:aint);
  236. procedure putreal(d:ppureal);
  237. procedure putstring(s:string);
  238. procedure putnormalset(const b);
  239. procedure putsmallset(const b);
  240. procedure tempclose;
  241. function tempopen:boolean;
  242. end;
  243. implementation
  244. uses
  245. systems,
  246. {$ifdef Test_Double_checksum}
  247. comphook,
  248. {$endif def Test_Double_checksum}
  249. fpccrc,
  250. cutils;
  251. {*****************************************************************************
  252. Endian Handling
  253. *****************************************************************************}
  254. Function SwapLong(x : longint): longint;
  255. var
  256. y : word;
  257. z : word;
  258. Begin
  259. y := x shr 16;
  260. y := word(longint(y) shl 8) or (y shr 8);
  261. z := x and $FFFF;
  262. z := word(longint(z) shl 8) or (z shr 8);
  263. SwapLong := (longint(z) shl 16) or longint(y);
  264. End;
  265. Function SwapWord(x : word): word;
  266. var
  267. z : byte;
  268. Begin
  269. z := x shr 8;
  270. x := x and $ff;
  271. x := word(x shl 8);
  272. SwapWord := x or z;
  273. End;
  274. {*****************************************************************************
  275. TPPUFile
  276. *****************************************************************************}
  277. constructor tppufile.Create(const fn:string);
  278. begin
  279. fname:=fn;
  280. change_endian:=false;
  281. crc_only:=false;
  282. Mode:=0;
  283. NewHeader;
  284. Error:=false;
  285. closed:=true;
  286. tempclosed:=false;
  287. getmem(buf,ppubufsize);
  288. end;
  289. destructor tppufile.destroy;
  290. begin
  291. closefile;
  292. if assigned(buf) then
  293. freemem(buf,ppubufsize);
  294. end;
  295. procedure tppufile.flush;
  296. begin
  297. if Mode=2 then
  298. writebuf;
  299. end;
  300. procedure tppufile.closefile;
  301. begin
  302. {$ifdef Test_Double_checksum}
  303. if mode=2 then
  304. begin
  305. if assigned(crc_test) then
  306. dispose(crc_test);
  307. if assigned(crc_test2) then
  308. dispose(crc_test2);
  309. end;
  310. {$endif Test_Double_checksum}
  311. if Mode<>0 then
  312. begin
  313. Flush;
  314. {$I-}
  315. system.close(f);
  316. {$I+}
  317. if ioresult<>0 then;
  318. Mode:=0;
  319. closed:=true;
  320. end;
  321. end;
  322. function tppufile.CheckPPUId:boolean;
  323. begin
  324. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  325. end;
  326. function tppufile.GetPPUVersion:integer;
  327. var
  328. l : integer;
  329. code : integer;
  330. begin
  331. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  332. if code=0 then
  333. GetPPUVersion:=l
  334. else
  335. GetPPUVersion:=0;
  336. end;
  337. procedure tppufile.NewHeader;
  338. var
  339. s : string;
  340. begin
  341. fillchar(header,sizeof(tppuheader),0);
  342. str(currentppuversion,s);
  343. while length(s)<3 do
  344. s:='0'+s;
  345. with header do
  346. begin
  347. Id[1]:='P';
  348. Id[2]:='P';
  349. Id[3]:='U';
  350. Ver[1]:=s[1];
  351. Ver[2]:=s[2];
  352. Ver[3]:=s[3];
  353. end;
  354. end;
  355. {*****************************************************************************
  356. TPPUFile Reading
  357. *****************************************************************************}
  358. function tppufile.openfile:boolean;
  359. var
  360. ofmode : byte;
  361. i : integer;
  362. begin
  363. openfile:=false;
  364. assign(f,fname);
  365. ofmode:=filemode;
  366. filemode:=$0;
  367. {$I-}
  368. reset(f,1);
  369. {$I+}
  370. filemode:=ofmode;
  371. if ioresult<>0 then
  372. exit;
  373. closed:=false;
  374. {read ppuheader}
  375. fsize:=filesize(f);
  376. if fsize<sizeof(tppuheader) then
  377. exit;
  378. blockread(f,header,sizeof(tppuheader),i);
  379. { The header is always stored in little endian order }
  380. { therefore swap if on a big endian machine }
  381. {$IFDEF ENDIAN_BIG}
  382. header.compiler := SwapWord(header.compiler);
  383. header.cpu := SwapWord(header.cpu);
  384. header.target := SwapWord(header.target);
  385. header.flags := SwapLong(header.flags);
  386. header.size := SwapLong(header.size);
  387. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  388. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  389. {$ENDIF}
  390. { the PPU DATA is stored in native order }
  391. if (header.flags and uf_big_endian) = uf_big_endian then
  392. Begin
  393. {$IFDEF ENDIAN_LITTLE}
  394. change_endian := TRUE;
  395. {$ELSE}
  396. change_endian := FALSE;
  397. {$ENDIF}
  398. End
  399. else if (header.flags and uf_little_endian) = uf_little_endian then
  400. Begin
  401. {$IFDEF ENDIAN_BIG}
  402. change_endian := TRUE;
  403. {$ELSE}
  404. change_endian := FALSE;
  405. {$ENDIF}
  406. End;
  407. {reset buffer}
  408. bufstart:=i;
  409. bufsize:=0;
  410. bufidx:=0;
  411. Mode:=1;
  412. FillChar(entry,sizeof(tppuentry),0);
  413. entryidx:=0;
  414. entrystart:=0;
  415. entrybufstart:=0;
  416. Error:=false;
  417. openfile:=true;
  418. end;
  419. procedure tppufile.reloadbuf;
  420. begin
  421. inc(bufstart,bufsize);
  422. blockread(f,buf^,ppubufsize,bufsize);
  423. bufidx:=0;
  424. end;
  425. procedure tppufile.readdata(var b;len:integer);
  426. var
  427. p,pmax,pbuf : pchar;
  428. left : integer;
  429. begin
  430. p:=pchar(@b);
  431. pbuf:=@buf[bufidx];
  432. repeat
  433. left:=bufsize-bufidx;
  434. if len<left then
  435. break;
  436. move(pbuf^,p^,left);
  437. dec(len,left);
  438. inc(p,left);
  439. reloadbuf;
  440. pbuf:=@buf[bufidx];
  441. if bufsize=0 then
  442. exit;
  443. until false;
  444. { For small values copy directly }
  445. if len<=sizeof(ptrint) then
  446. begin
  447. pmax:=p+len;
  448. while (p<pmax) do
  449. begin
  450. p^:=pbuf^;
  451. inc(pbuf);
  452. inc(p);
  453. end;
  454. end
  455. else
  456. move(pbuf^,p^,len);
  457. inc(bufidx,len);
  458. end;
  459. procedure tppufile.skipdata(len:integer);
  460. var
  461. left : integer;
  462. begin
  463. while len>0 do
  464. begin
  465. left:=bufsize-bufidx;
  466. if len>left then
  467. begin
  468. dec(len,left);
  469. reloadbuf;
  470. if bufsize=0 then
  471. exit;
  472. end
  473. else
  474. begin
  475. inc(bufidx,len);
  476. exit;
  477. end;
  478. end;
  479. end;
  480. function tppufile.readentry:byte;
  481. begin
  482. if entryidx<entry.size then
  483. skipdata(entry.size-entryidx);
  484. readdata(entry,sizeof(tppuentry));
  485. if change_endian then
  486. entry.size:=swaplong(entry.size);
  487. entrystart:=bufstart+bufidx;
  488. entryidx:=0;
  489. if not(entry.id in [mainentryid,subentryid]) then
  490. begin
  491. readentry:=iberror;
  492. error:=true;
  493. exit;
  494. end;
  495. readentry:=entry.nr;
  496. end;
  497. function tppufile.endofentry:boolean;
  498. begin
  499. endofentry:=(entryidx>=entry.size);
  500. end;
  501. function tppufile.entrysize:longint;
  502. begin
  503. entrysize:=entry.size;
  504. end;
  505. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  506. begin
  507. if entryidx+len>entry.size then
  508. res:=entry.size-entryidx
  509. else
  510. res:=len;
  511. readdata(b,res);
  512. inc(entryidx,res);
  513. end;
  514. procedure tppufile.getdata(var b;len:integer);
  515. begin
  516. if entryidx+len>entry.size then
  517. begin
  518. error:=true;
  519. exit;
  520. end;
  521. readdata(b,len);
  522. inc(entryidx,len);
  523. end;
  524. function tppufile.getbyte:byte;
  525. var
  526. b : byte;
  527. begin
  528. if entryidx+1>entry.size then
  529. begin
  530. error:=true;
  531. getbyte:=0;
  532. exit;
  533. end;
  534. readdata(b,1);
  535. getbyte:=b;
  536. inc(entryidx);
  537. end;
  538. function tppufile.getword:word;
  539. var
  540. w : word;
  541. begin
  542. if entryidx+2>entry.size then
  543. begin
  544. error:=true;
  545. getword:=0;
  546. exit;
  547. end;
  548. readdata(w,2);
  549. if change_endian then
  550. getword:=swapword(w)
  551. else
  552. getword:=w;
  553. inc(entryidx,2);
  554. end;
  555. function tppufile.getlongint:longint;
  556. var
  557. l : longint;
  558. begin
  559. if entryidx+4>entry.size then
  560. begin
  561. error:=true;
  562. getlongint:=0;
  563. exit;
  564. end;
  565. readdata(l,4);
  566. if change_endian then
  567. getlongint:=swaplong(l)
  568. else
  569. getlongint:=l;
  570. inc(entryidx,4);
  571. end;
  572. function tppufile.getint64:int64;
  573. var
  574. i : int64;
  575. begin
  576. if entryidx+8>entry.size then
  577. begin
  578. error:=true;
  579. result:=0;
  580. exit;
  581. end;
  582. readdata(i,8);
  583. if change_endian then
  584. result:=swapint64(i)
  585. else
  586. result:=i;
  587. inc(entryidx,8);
  588. end;
  589. function tppufile.getaint:aint;
  590. begin
  591. {$ifdef cpu64bit}
  592. result:=getint64;
  593. {$else cpu64bit}
  594. result:=getlongint;
  595. {$endif cpu64bit}
  596. end;
  597. function tppufile.getreal:ppureal;
  598. var
  599. d : ppureal;
  600. hd : double;
  601. begin
  602. if target_info.system=system_x86_64_win64 then
  603. begin
  604. if entryidx+sizeof(hd)>entry.size then
  605. begin
  606. error:=true;
  607. getreal:=0;
  608. exit;
  609. end;
  610. readdata(hd,sizeof(hd));
  611. getreal:=hd;
  612. inc(entryidx,sizeof(hd));
  613. end
  614. else
  615. begin
  616. if entryidx+sizeof(ppureal)>entry.size then
  617. begin
  618. error:=true;
  619. getreal:=0;
  620. exit;
  621. end;
  622. readdata(d,sizeof(ppureal));
  623. getreal:=d;
  624. inc(entryidx,sizeof(ppureal));
  625. end;
  626. end;
  627. function tppufile.getstring:string;
  628. var
  629. s : string;
  630. begin
  631. s[0]:=chr(getbyte);
  632. if entryidx+length(s)>entry.size then
  633. begin
  634. error:=true;
  635. exit;
  636. end;
  637. ReadData(s[1],length(s));
  638. getstring:=s;
  639. inc(entryidx,length(s));
  640. end;
  641. procedure tppufile.getsmallset(var b);
  642. var
  643. l : longint;
  644. begin
  645. l:=getlongint;
  646. longint(b):=l;
  647. end;
  648. procedure tppufile.getnormalset(var b);
  649. type
  650. SetLongintArray = Array [0..7] of longint;
  651. var
  652. i : longint;
  653. begin
  654. if change_endian then
  655. begin
  656. for i:=0 to 7 do
  657. SetLongintArray(b)[i]:=getlongint;
  658. end
  659. else
  660. getdata(b,32);
  661. end;
  662. function tppufile.skipuntilentry(untilb:byte):boolean;
  663. var
  664. b : byte;
  665. begin
  666. repeat
  667. b:=readentry;
  668. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  669. skipuntilentry:=(b=untilb);
  670. end;
  671. {*****************************************************************************
  672. TPPUFile Writing
  673. *****************************************************************************}
  674. function tppufile.createfile:boolean;
  675. begin
  676. createfile:=false;
  677. {$ifdef INTFPPU}
  678. if crc_only then
  679. begin
  680. fname:=fname+'.intf';
  681. crc_only:=false;
  682. end;
  683. {$endif}
  684. if not crc_only then
  685. begin
  686. assign(f,fname);
  687. {$ifdef MACOS}
  688. {FPas is FreePascal's creator code on MacOS. See systems/mac_crea.txt}
  689. SetDefaultMacOSCreator('FPas');
  690. SetDefaultMacOSFiletype('FPPU');
  691. {$endif}
  692. {$I-}
  693. rewrite(f,1);
  694. {$I+}
  695. {$ifdef MACOS}
  696. SetDefaultMacOSCreator('MPS ');
  697. SetDefaultMacOSFiletype('TEXT');
  698. {$endif}
  699. if ioresult<>0 then
  700. exit;
  701. Mode:=2;
  702. {write header for sure}
  703. blockwrite(f,header,sizeof(tppuheader));
  704. end;
  705. bufsize:=ppubufsize;
  706. bufstart:=sizeof(tppuheader);
  707. bufidx:=0;
  708. {reset}
  709. crc:=cardinal($ffffffff);
  710. interface_crc:=cardinal($ffffffff);
  711. do_interface_crc:=true;
  712. Error:=false;
  713. do_crc:=true;
  714. size:=0;
  715. entrytyp:=mainentryid;
  716. {start}
  717. NewEntry;
  718. createfile:=true;
  719. end;
  720. procedure tppufile.writeheader;
  721. var
  722. opos : integer;
  723. begin
  724. if crc_only then
  725. exit;
  726. { flush buffer }
  727. writebuf;
  728. { update size (w/o header!) in the header }
  729. header.size:=bufstart-sizeof(tppuheader);
  730. { set the endian flag }
  731. {$ifndef FPC_BIG_ENDIAN}
  732. header.flags := header.flags or uf_little_endian;
  733. {$else not FPC_BIG_ENDIAN}
  734. header.flags := header.flags or uf_big_endian;
  735. { Now swap the header in the correct endian (always little endian) }
  736. header.compiler := SwapWord(header.compiler);
  737. header.cpu := SwapWord(header.cpu);
  738. header.target := SwapWord(header.target);
  739. header.flags := SwapLong(header.flags);
  740. header.size := SwapLong(header.size);
  741. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  742. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  743. {$endif not FPC_BIG_ENDIAN}
  744. { write header and restore filepos after it }
  745. opos:=filepos(f);
  746. seek(f,0);
  747. blockwrite(f,header,sizeof(tppuheader));
  748. seek(f,opos);
  749. end;
  750. procedure tppufile.writebuf;
  751. begin
  752. if not crc_only and
  753. (bufidx <> 0) then
  754. blockwrite(f,buf^,bufidx);
  755. inc(bufstart,bufidx);
  756. bufidx:=0;
  757. end;
  758. procedure tppufile.writedata(const b;len:integer);
  759. var
  760. p : pchar;
  761. left,
  762. idx : integer;
  763. begin
  764. if crc_only then
  765. exit;
  766. p:=pchar(@b);
  767. idx:=0;
  768. while len>0 do
  769. begin
  770. left:=bufsize-bufidx;
  771. if len>left then
  772. begin
  773. move(p[idx],buf[bufidx],left);
  774. dec(len,left);
  775. inc(idx,left);
  776. inc(bufidx,left);
  777. writebuf;
  778. end
  779. else
  780. begin
  781. move(p[idx],buf[bufidx],len);
  782. inc(bufidx,len);
  783. exit;
  784. end;
  785. end;
  786. end;
  787. procedure tppufile.NewEntry;
  788. begin
  789. with entry do
  790. begin
  791. id:=entrytyp;
  792. nr:=ibend;
  793. size:=0;
  794. end;
  795. {Reset Entry State}
  796. entryidx:=0;
  797. entrybufstart:=bufstart;
  798. entrystart:=bufstart+bufidx;
  799. {Alloc in buffer}
  800. writedata(entry,sizeof(tppuentry));
  801. end;
  802. procedure tppufile.writeentry(ibnr:byte);
  803. var
  804. opos : integer;
  805. begin
  806. {create entry}
  807. entry.id:=entrytyp;
  808. entry.nr:=ibnr;
  809. entry.size:=entryidx;
  810. {it's already been sent to disk ?}
  811. if entrybufstart<>bufstart then
  812. begin
  813. if not crc_only then
  814. begin
  815. {flush to be sure}
  816. WriteBuf;
  817. {write entry}
  818. opos:=filepos(f);
  819. seek(f,entrystart);
  820. blockwrite(f,entry,sizeof(tppuentry));
  821. seek(f,opos);
  822. end;
  823. entrybufstart:=bufstart;
  824. end
  825. else
  826. move(entry,buf[entrystart-bufstart],sizeof(entry));
  827. {Add New Entry, which is ibend by default}
  828. entrystart:=bufstart+bufidx; {next entry position}
  829. NewEntry;
  830. end;
  831. procedure tppufile.putdata(const b;len:integer);
  832. begin
  833. if do_crc then
  834. begin
  835. crc:=UpdateCrc32(crc,b,len);
  836. {$ifdef Test_Double_checksum}
  837. if crc_only then
  838. begin
  839. crc_test2^[crc_index2]:=crc;
  840. {$ifdef Test_Double_checksum_write}
  841. Writeln(CRCFile,crc);
  842. {$endif Test_Double_checksum_write}
  843. if crc_index2<crc_array_size then
  844. inc(crc_index2);
  845. end
  846. else
  847. begin
  848. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  849. (crc_test2^[crcindex2]<>crc) then
  850. Do_comment(V_Note,'impl CRC changed');
  851. {$ifdef Test_Double_checksum_write}
  852. Writeln(CRCFile,crc);
  853. {$endif Test_Double_checksum_write}
  854. inc(crcindex2);
  855. end;
  856. {$endif def Test_Double_checksum}
  857. if do_interface_crc then
  858. begin
  859. interface_crc:=UpdateCrc32(interface_crc,b,len);
  860. {$ifdef Test_Double_checksum}
  861. if crc_only then
  862. begin
  863. crc_test^[crc_index]:=interface_crc;
  864. {$ifdef Test_Double_checksum_write}
  865. Writeln(CRCFile,interface_crc);
  866. {$endif Test_Double_checksum_write}
  867. if crc_index<crc_array_size then
  868. inc(crc_index);
  869. end
  870. else
  871. begin
  872. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  873. (crc_test^[crcindex]<>interface_crc) then
  874. Do_comment(V_Warning,'CRC changed');
  875. {$ifdef Test_Double_checksum_write}
  876. Writeln(CRCFile,interface_crc);
  877. {$endif Test_Double_checksum_write}
  878. inc(crcindex);
  879. end;
  880. {$endif def Test_Double_checksum}
  881. end;
  882. end;
  883. if not crc_only then
  884. writedata(b,len);
  885. inc(entryidx,len);
  886. end;
  887. procedure tppufile.putbyte(b:byte);
  888. begin
  889. putdata(b,1);
  890. end;
  891. procedure tppufile.putword(w:word);
  892. begin
  893. putdata(w,2);
  894. end;
  895. procedure tppufile.putlongint(l:longint);
  896. begin
  897. putdata(l,4);
  898. end;
  899. procedure tppufile.putint64(i:int64);
  900. begin
  901. putdata(i,8);
  902. end;
  903. procedure tppufile.putaint(i:aint);
  904. begin
  905. putdata(i,sizeof(aint));
  906. end;
  907. procedure tppufile.putreal(d:ppureal);
  908. var
  909. hd : double;
  910. begin
  911. if target_info.system=system_x86_64_win64 then
  912. begin
  913. hd:=d;
  914. putdata(hd,sizeof(hd));
  915. end
  916. else
  917. putdata(d,sizeof(ppureal));
  918. end;
  919. procedure tppufile.putstring(s:string);
  920. begin
  921. putdata(s,length(s)+1);
  922. end;
  923. procedure tppufile.putsmallset(const b);
  924. var
  925. l : longint;
  926. begin
  927. l:=longint(b);
  928. putlongint(l);
  929. end;
  930. procedure tppufile.putnormalset(const b);
  931. type
  932. SetLongintArray = Array [0..7] of longint;
  933. var
  934. i : longint;
  935. tempb : setlongintarray;
  936. begin
  937. if change_endian then
  938. begin
  939. for i:=0 to 7 do
  940. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  941. putdata(tempb,32);
  942. end
  943. else
  944. putdata(b,32);
  945. end;
  946. procedure tppufile.tempclose;
  947. begin
  948. if not closed then
  949. begin
  950. closepos:=filepos(f);
  951. {$I-}
  952. system.close(f);
  953. {$I+}
  954. if ioresult<>0 then;
  955. closed:=true;
  956. tempclosed:=true;
  957. end;
  958. end;
  959. function tppufile.tempopen:boolean;
  960. var
  961. ofm : byte;
  962. begin
  963. tempopen:=false;
  964. if not closed or not tempclosed then
  965. exit;
  966. ofm:=filemode;
  967. filemode:=0;
  968. {$I-}
  969. reset(f,1);
  970. {$I+}
  971. filemode:=ofm;
  972. if ioresult<>0 then
  973. exit;
  974. closed:=false;
  975. tempclosed:=false;
  976. { restore state }
  977. seek(f,closepos);
  978. tempopen:=true;
  979. end;
  980. end.