ppu.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Routines to read/write ppu files
  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 ppu;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. globtype;
  23. { Also write the ppu if only crc if done, this can be used with ppudump to
  24. see the differences between the intf and implementation }
  25. { define INTFPPU}
  26. {$ifdef Test_Double_checksum}
  27. var
  28. CRCFile : text;
  29. const
  30. CRC_array_Size = 200000;
  31. type
  32. tcrc_array = array[0..crc_array_size] of longint;
  33. pcrc_array = ^tcrc_array;
  34. {$endif Test_Double_checksum}
  35. const
  36. {$ifdef ansistring_bits}
  37. CurrentPPUVersion=41;
  38. {$else}
  39. CurrentPPUVersion=40;
  40. {$endif}
  41. { buffer sizes }
  42. maxentrysize = 1024;
  43. ppubufsize = 16384;
  44. {ppu entries}
  45. mainentryid = 1;
  46. subentryid = 2;
  47. {special}
  48. iberror = 0;
  49. ibstartdefs = 248;
  50. ibenddefs = 249;
  51. ibstartsyms = 250;
  52. ibendsyms = 251;
  53. ibendinterface = 252;
  54. ibendimplementation = 253;
  55. ibendbrowser = 254;
  56. ibend = 255;
  57. {general}
  58. ibmodulename = 1;
  59. ibsourcefiles = 2;
  60. ibloadunit = 3;
  61. ibinitunit = 4;
  62. iblinkunitofiles = 5;
  63. iblinkunitstaticlibs = 6;
  64. iblinkunitsharedlibs = 7;
  65. iblinkotherofiles = 8;
  66. iblinkotherstaticlibs = 9;
  67. iblinkothersharedlibs = 10;
  68. ibdbxcount = 11;
  69. ibsymref = 12;
  70. ibdefref = 13;
  71. ibendsymtablebrowser = 14;
  72. ibbeginsymtablebrowser = 15;
  73. ibusedmacros = 16;
  74. ibderefdata = 17;
  75. {syms}
  76. ibtypesym = 20;
  77. ibprocsym = 21;
  78. ibvarsym = 22;
  79. ibconstsym = 23;
  80. ibenumsym = 24;
  81. ibtypedconstsym = 25;
  82. ibabsolutesym = 26;
  83. ibpropertysym = 27;
  84. ibvarsym_C = 28;
  85. ibunitsym = 29; { needed for browser }
  86. iblabelsym = 30;
  87. ibsyssym = 31;
  88. ibrttisym = 32;
  89. {definitions}
  90. iborddef = 40;
  91. ibpointerdef = 41;
  92. ibarraydef = 42;
  93. ibprocdef = 43;
  94. ibshortstringdef = 44;
  95. ibrecorddef = 45;
  96. ibfiledef = 46;
  97. ibformaldef = 47;
  98. ibobjectdef = 48;
  99. ibenumdef = 49;
  100. ibsetdef = 50;
  101. ibprocvardef = 51;
  102. ibfloatdef = 52;
  103. ibclassrefdef = 53;
  104. iblongstringdef = 54;
  105. {$ifdef ansistring_bits}
  106. ibansistring16def = 58;
  107. ibansistring32def = 55;
  108. ibansistring64def = 59;
  109. {$else}
  110. ibansistringdef = 55;
  111. {$endif}
  112. ibwidestringdef = 56;
  113. ibvariantdef = 57;
  114. {implementation/objectdata}
  115. ibnodetree = 80;
  116. ibasmsymbols = 81;
  117. { unit flags }
  118. uf_init = $1;
  119. uf_finalize = $2;
  120. uf_big_endian = $4;
  121. uf_has_dbx = $8;
  122. uf_has_browser = $10;
  123. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  124. uf_smart_linked = $40; { the ppu can be smartlinked }
  125. uf_static_linked = $80; { the ppu can be linked static }
  126. uf_shared_linked = $100; { the ppu can be linked shared }
  127. uf_local_browser = $200;
  128. uf_no_link = $400; { unit has no .o generated, but can still have
  129. external linking! }
  130. uf_has_resources = $800; { unit has resource section }
  131. uf_little_endian = $1000;
  132. uf_release = $2000; { unit was compiled with -Ur option }
  133. uf_threadvars = $4000; { unit has threadvars }
  134. uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
  135. uf_has_debuginfo = $10000; { this unit has debuginfo generated }
  136. type
  137. ppureal=extended;
  138. tppuerror=(ppuentrytoobig,ppuentryerror);
  139. tppuheader=packed record { 36 bytes }
  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. future : array[0..2] of longint;
  150. end;
  151. tppuentry=packed record
  152. size : longint;
  153. id : byte;
  154. nr : byte;
  155. end;
  156. tppufile=class
  157. private
  158. f : file;
  159. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  160. fname : string;
  161. fsize : integer;
  162. {$ifdef Test_Double_checksum}
  163. public
  164. crcindex,
  165. crc_index,
  166. crcindex2,
  167. crc_index2 : cardinal;
  168. crc_test,
  169. crc_test2 : pcrc_array;
  170. private
  171. {$endif def Test_Double_checksum}
  172. change_endian : boolean;
  173. buf : pchar;
  174. bufstart,
  175. bufsize,
  176. bufidx : integer;
  177. entrybufstart,
  178. entrystart,
  179. entryidx : integer;
  180. entry : tppuentry;
  181. closed,
  182. tempclosed : boolean;
  183. closepos : integer;
  184. public
  185. entrytyp : byte;
  186. header : tppuheader;
  187. size : integer;
  188. crc,
  189. interface_crc : cardinal;
  190. error,
  191. do_crc,
  192. do_interface_crc : boolean;
  193. crc_only : boolean; { used to calculate interface_crc before implementation }
  194. constructor Create(const fn:string);
  195. destructor Destroy;override;
  196. procedure flush;
  197. procedure closefile;
  198. function CheckPPUId:boolean;
  199. function GetPPUVersion:integer;
  200. procedure NewHeader;
  201. procedure NewEntry;
  202. {read}
  203. function openfile:boolean;
  204. procedure reloadbuf;
  205. procedure readdata(var b;len:integer);
  206. procedure skipdata(len:integer);
  207. function readentry:byte;
  208. function EndOfEntry:boolean;
  209. function entrysize:longint;
  210. procedure getdatabuf(var b;len:integer;var res:integer);
  211. procedure getdata(var b;len:integer);
  212. function getbyte:byte;
  213. function getword:word;
  214. function getlongint:longint;
  215. function getint64:int64;
  216. function getaint:aint;
  217. function getreal:ppureal;
  218. function getstring:string;
  219. procedure getnormalset(var b);
  220. procedure getsmallset(var b);
  221. function skipuntilentry(untilb:byte):boolean;
  222. {write}
  223. function createfile:boolean;
  224. procedure writeheader;
  225. procedure writebuf;
  226. procedure writedata(const b;len:integer);
  227. procedure writeentry(ibnr:byte);
  228. procedure putdata(const b;len:integer);
  229. procedure putbyte(b:byte);
  230. procedure putword(w:word);
  231. procedure putlongint(l:longint);
  232. procedure putint64(i:int64);
  233. procedure putaint(i:aint);
  234. procedure putreal(d:ppureal);
  235. procedure putstring(s:string);
  236. procedure putnormalset(const b);
  237. procedure putsmallset(const b);
  238. procedure tempclose;
  239. function tempopen:boolean;
  240. end;
  241. implementation
  242. uses
  243. {$ifdef Test_Double_checksum}
  244. comphook,
  245. {$endif def Test_Double_checksum}
  246. crc,
  247. cutils;
  248. {*****************************************************************************
  249. Endian Handling
  250. *****************************************************************************}
  251. Function SwapLong(x : longint): longint;
  252. var
  253. y : word;
  254. z : word;
  255. Begin
  256. y := x shr 16;
  257. y := word(longint(y) shl 8) or (y shr 8);
  258. z := x and $FFFF;
  259. z := word(longint(z) shl 8) or (z shr 8);
  260. SwapLong := (longint(z) shl 16) or longint(y);
  261. End;
  262. Function SwapWord(x : word): word;
  263. var
  264. z : byte;
  265. Begin
  266. z := x shr 8;
  267. x := x and $ff;
  268. x := word(x shl 8);
  269. SwapWord := x or z;
  270. End;
  271. {*****************************************************************************
  272. TPPUFile
  273. *****************************************************************************}
  274. constructor tppufile.Create(const fn:string);
  275. begin
  276. fname:=fn;
  277. change_endian:=false;
  278. crc_only:=false;
  279. Mode:=0;
  280. NewHeader;
  281. Error:=false;
  282. closed:=true;
  283. tempclosed:=false;
  284. getmem(buf,ppubufsize);
  285. end;
  286. destructor tppufile.destroy;
  287. begin
  288. closefile;
  289. if assigned(buf) then
  290. freemem(buf,ppubufsize);
  291. end;
  292. procedure tppufile.flush;
  293. begin
  294. if Mode=2 then
  295. writebuf;
  296. end;
  297. procedure tppufile.closefile;
  298. begin
  299. {$ifdef Test_Double_checksum}
  300. if mode=2 then
  301. begin
  302. if assigned(crc_test) then
  303. dispose(crc_test);
  304. if assigned(crc_test2) then
  305. dispose(crc_test2);
  306. end;
  307. {$endif Test_Double_checksum}
  308. if Mode<>0 then
  309. begin
  310. Flush;
  311. {$I-}
  312. system.close(f);
  313. {$I+}
  314. if ioresult<>0 then;
  315. Mode:=0;
  316. closed:=true;
  317. end;
  318. end;
  319. function tppufile.CheckPPUId:boolean;
  320. begin
  321. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  322. end;
  323. function tppufile.GetPPUVersion:integer;
  324. var
  325. l : integer;
  326. code : integer;
  327. begin
  328. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  329. if code=0 then
  330. GetPPUVersion:=l
  331. else
  332. GetPPUVersion:=0;
  333. end;
  334. procedure tppufile.NewHeader;
  335. var
  336. s : string;
  337. begin
  338. fillchar(header,sizeof(tppuheader),0);
  339. str(currentppuversion,s);
  340. while length(s)<3 do
  341. s:='0'+s;
  342. with header do
  343. begin
  344. Id[1]:='P';
  345. Id[2]:='P';
  346. Id[3]:='U';
  347. Ver[1]:=s[1];
  348. Ver[2]:=s[2];
  349. Ver[3]:=s[3];
  350. end;
  351. end;
  352. {*****************************************************************************
  353. TPPUFile Reading
  354. *****************************************************************************}
  355. function tppufile.openfile:boolean;
  356. var
  357. ofmode : byte;
  358. i : integer;
  359. begin
  360. openfile:=false;
  361. assign(f,fname);
  362. ofmode:=filemode;
  363. filemode:=$0;
  364. {$I-}
  365. reset(f,1);
  366. {$I+}
  367. filemode:=ofmode;
  368. if ioresult<>0 then
  369. exit;
  370. closed:=false;
  371. {read ppuheader}
  372. fsize:=filesize(f);
  373. if fsize<sizeof(tppuheader) then
  374. exit;
  375. blockread(f,header,sizeof(tppuheader),i);
  376. { The header is always stored in little endian order }
  377. { therefore swap if on a big endian machine }
  378. {$IFDEF ENDIAN_BIG}
  379. header.compiler := SwapWord(header.compiler);
  380. header.cpu := SwapWord(header.cpu);
  381. header.target := SwapWord(header.target);
  382. header.flags := SwapLong(header.flags);
  383. header.size := SwapLong(header.size);
  384. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  385. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  386. {$ENDIF}
  387. { the PPU DATA is stored in native order }
  388. if (header.flags and uf_big_endian) = uf_big_endian then
  389. Begin
  390. {$IFDEF ENDIAN_LITTLE}
  391. change_endian := TRUE;
  392. {$ELSE}
  393. change_endian := FALSE;
  394. {$ENDIF}
  395. End
  396. else if (header.flags and uf_little_endian) = uf_little_endian then
  397. Begin
  398. {$IFDEF ENDIAN_BIG}
  399. change_endian := TRUE;
  400. {$ELSE}
  401. change_endian := FALSE;
  402. {$ENDIF}
  403. End;
  404. {reset buffer}
  405. bufstart:=i;
  406. bufsize:=0;
  407. bufidx:=0;
  408. Mode:=1;
  409. FillChar(entry,sizeof(tppuentry),0);
  410. entryidx:=0;
  411. entrystart:=0;
  412. entrybufstart:=0;
  413. Error:=false;
  414. openfile:=true;
  415. end;
  416. procedure tppufile.reloadbuf;
  417. begin
  418. inc(bufstart,bufsize);
  419. blockread(f,buf^,ppubufsize,bufsize);
  420. bufidx:=0;
  421. end;
  422. procedure tppufile.readdata(var b;len:integer);
  423. var
  424. p : pchar;
  425. left,
  426. idx : integer;
  427. begin
  428. p:=pchar(@b);
  429. idx:=0;
  430. while len>0 do
  431. begin
  432. left:=bufsize-bufidx;
  433. if len>left then
  434. begin
  435. move(buf[bufidx],p[idx],left);
  436. dec(len,left);
  437. inc(idx,left);
  438. reloadbuf;
  439. if bufsize=0 then
  440. exit;
  441. end
  442. else
  443. begin
  444. move(buf[bufidx],p[idx],len);
  445. inc(bufidx,len);
  446. exit;
  447. end;
  448. end;
  449. end;
  450. procedure tppufile.skipdata(len:integer);
  451. var
  452. left : integer;
  453. begin
  454. while len>0 do
  455. begin
  456. left:=bufsize-bufidx;
  457. if len>left then
  458. begin
  459. dec(len,left);
  460. reloadbuf;
  461. if bufsize=0 then
  462. exit;
  463. end
  464. else
  465. begin
  466. inc(bufidx,len);
  467. exit;
  468. end;
  469. end;
  470. end;
  471. function tppufile.readentry:byte;
  472. begin
  473. if entryidx<entry.size then
  474. skipdata(entry.size-entryidx);
  475. readdata(entry,sizeof(tppuentry));
  476. entrystart:=bufstart+bufidx;
  477. entryidx:=0;
  478. if not(entry.id in [mainentryid,subentryid]) then
  479. begin
  480. readentry:=iberror;
  481. error:=true;
  482. exit;
  483. end;
  484. readentry:=entry.nr;
  485. end;
  486. function tppufile.endofentry:boolean;
  487. begin
  488. endofentry:=(entryidx>=entry.size);
  489. end;
  490. function tppufile.entrysize:longint;
  491. begin
  492. entrysize:=entry.size;
  493. end;
  494. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  495. begin
  496. if entryidx+len>entry.size then
  497. res:=entry.size-entryidx
  498. else
  499. res:=len;
  500. readdata(b,res);
  501. inc(entryidx,res);
  502. end;
  503. procedure tppufile.getdata(var b;len:integer);
  504. begin
  505. if entryidx+len>entry.size then
  506. begin
  507. error:=true;
  508. exit;
  509. end;
  510. readdata(b,len);
  511. inc(entryidx,len);
  512. end;
  513. function tppufile.getbyte:byte;
  514. var
  515. b : byte;
  516. begin
  517. if entryidx+1>entry.size then
  518. begin
  519. error:=true;
  520. getbyte:=0;
  521. exit;
  522. end;
  523. readdata(b,1);
  524. getbyte:=b;
  525. inc(entryidx);
  526. end;
  527. function tppufile.getword:word;
  528. var
  529. w : word;
  530. begin
  531. if entryidx+2>entry.size then
  532. begin
  533. error:=true;
  534. getword:=0;
  535. exit;
  536. end;
  537. readdata(w,2);
  538. if change_endian then
  539. getword:=swapword(w)
  540. else
  541. getword:=w;
  542. inc(entryidx,2);
  543. end;
  544. function tppufile.getlongint:longint;
  545. var
  546. l : longint;
  547. begin
  548. if entryidx+4>entry.size then
  549. begin
  550. error:=true;
  551. getlongint:=0;
  552. exit;
  553. end;
  554. readdata(l,4);
  555. if change_endian then
  556. getlongint:=swaplong(l)
  557. else
  558. getlongint:=l;
  559. inc(entryidx,4);
  560. end;
  561. function tppufile.getint64:int64;
  562. var
  563. i : int64;
  564. begin
  565. if entryidx+8>entry.size then
  566. begin
  567. error:=true;
  568. result:=0;
  569. exit;
  570. end;
  571. readdata(i,8);
  572. if change_endian then
  573. result:=swapint64(i)
  574. else
  575. result:=i;
  576. inc(entryidx,8);
  577. end;
  578. function tppufile.getaint:aint;
  579. begin
  580. {$ifdef cpu64bit}
  581. result:=getint64;
  582. {$else cpu64bit}
  583. result:=getlongint;
  584. {$endif cpu64bit}
  585. end;
  586. function tppufile.getreal:ppureal;
  587. var
  588. d : ppureal;
  589. begin
  590. if entryidx+sizeof(ppureal)>entry.size then
  591. begin
  592. error:=true;
  593. getreal:=0;
  594. exit;
  595. end;
  596. readdata(d,sizeof(ppureal));
  597. getreal:=d;
  598. inc(entryidx,sizeof(ppureal));
  599. end;
  600. function tppufile.getstring:string;
  601. var
  602. s : string;
  603. begin
  604. s[0]:=chr(getbyte);
  605. if entryidx+length(s)>entry.size then
  606. begin
  607. error:=true;
  608. exit;
  609. end;
  610. ReadData(s[1],length(s));
  611. getstring:=s;
  612. inc(entryidx,length(s));
  613. end;
  614. procedure tppufile.getsmallset(var b);
  615. var
  616. l : longint;
  617. begin
  618. l:=getlongint;
  619. longint(b):=l;
  620. end;
  621. procedure tppufile.getnormalset(var b);
  622. type
  623. SetLongintArray = Array [0..7] of longint;
  624. var
  625. i : longint;
  626. begin
  627. if change_endian then
  628. begin
  629. for i:=0 to 7 do
  630. SetLongintArray(b)[i]:=getlongint;
  631. end
  632. else
  633. getdata(b,32);
  634. end;
  635. function tppufile.skipuntilentry(untilb:byte):boolean;
  636. var
  637. b : byte;
  638. begin
  639. repeat
  640. b:=readentry;
  641. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  642. skipuntilentry:=(b=untilb);
  643. end;
  644. {*****************************************************************************
  645. TPPUFile Writing
  646. *****************************************************************************}
  647. function tppufile.createfile:boolean;
  648. begin
  649. createfile:=false;
  650. {$ifdef INTFPPU}
  651. if crc_only then
  652. begin
  653. fname:=fname+'.intf';
  654. crc_only:=false;
  655. end;
  656. {$endif}
  657. if not crc_only then
  658. begin
  659. assign(f,fname);
  660. {$I-}
  661. rewrite(f,1);
  662. {$I+}
  663. if ioresult<>0 then
  664. exit;
  665. Mode:=2;
  666. {write header for sure}
  667. blockwrite(f,header,sizeof(tppuheader));
  668. end;
  669. bufsize:=ppubufsize;
  670. bufstart:=sizeof(tppuheader);
  671. bufidx:=0;
  672. {reset}
  673. crc:=cardinal($ffffffff);
  674. interface_crc:=cardinal($ffffffff);
  675. do_interface_crc:=true;
  676. Error:=false;
  677. do_crc:=true;
  678. size:=0;
  679. entrytyp:=mainentryid;
  680. {start}
  681. NewEntry;
  682. createfile:=true;
  683. end;
  684. procedure tppufile.writeheader;
  685. var
  686. opos : integer;
  687. begin
  688. if crc_only then
  689. exit;
  690. { flush buffer }
  691. writebuf;
  692. { update size (w/o header!) in the header }
  693. header.size:=bufstart-sizeof(tppuheader);
  694. { set the endian flag }
  695. {$ifndef FPC_BIG_ENDIAN}
  696. header.flags := header.flags or uf_little_endian;
  697. {$else not FPC_BIG_ENDIAN}
  698. header.flags := header.flags or uf_big_endian;
  699. { Now swap the header in the correct endian (always little endian) }
  700. header.compiler := SwapWord(header.compiler);
  701. header.cpu := SwapWord(header.cpu);
  702. header.target := SwapWord(header.target);
  703. header.flags := SwapLong(header.flags);
  704. header.size := SwapLong(header.size);
  705. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  706. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  707. {$endif not FPC_BIG_ENDIAN}
  708. { write header and restore filepos after it }
  709. opos:=filepos(f);
  710. seek(f,0);
  711. blockwrite(f,header,sizeof(tppuheader));
  712. seek(f,opos);
  713. end;
  714. procedure tppufile.writebuf;
  715. begin
  716. if not crc_only then
  717. blockwrite(f,buf^,bufidx);
  718. inc(bufstart,bufidx);
  719. bufidx:=0;
  720. end;
  721. procedure tppufile.writedata(const b;len:integer);
  722. var
  723. p : pchar;
  724. left,
  725. idx : integer;
  726. begin
  727. if crc_only then
  728. exit;
  729. p:=pchar(@b);
  730. idx:=0;
  731. while len>0 do
  732. begin
  733. left:=bufsize-bufidx;
  734. if len>left then
  735. begin
  736. move(p[idx],buf[bufidx],left);
  737. dec(len,left);
  738. inc(idx,left);
  739. inc(bufidx,left);
  740. writebuf;
  741. end
  742. else
  743. begin
  744. move(p[idx],buf[bufidx],len);
  745. inc(bufidx,len);
  746. exit;
  747. end;
  748. end;
  749. end;
  750. procedure tppufile.NewEntry;
  751. begin
  752. with entry do
  753. begin
  754. id:=entrytyp;
  755. nr:=ibend;
  756. size:=0;
  757. end;
  758. {Reset Entry State}
  759. entryidx:=0;
  760. entrybufstart:=bufstart;
  761. entrystart:=bufstart+bufidx;
  762. {Alloc in buffer}
  763. writedata(entry,sizeof(tppuentry));
  764. end;
  765. procedure tppufile.writeentry(ibnr:byte);
  766. var
  767. opos : integer;
  768. begin
  769. {create entry}
  770. entry.id:=entrytyp;
  771. entry.nr:=ibnr;
  772. entry.size:=entryidx;
  773. {it's already been sent to disk ?}
  774. if entrybufstart<>bufstart then
  775. begin
  776. if not crc_only then
  777. begin
  778. {flush to be sure}
  779. WriteBuf;
  780. {write entry}
  781. opos:=filepos(f);
  782. seek(f,entrystart);
  783. blockwrite(f,entry,sizeof(tppuentry));
  784. seek(f,opos);
  785. end;
  786. entrybufstart:=bufstart;
  787. end
  788. else
  789. move(entry,buf[entrystart-bufstart],sizeof(entry));
  790. {Add New Entry, which is ibend by default}
  791. entrystart:=bufstart+bufidx; {next entry position}
  792. NewEntry;
  793. end;
  794. procedure tppufile.putdata(const b;len:integer);
  795. begin
  796. if do_crc then
  797. begin
  798. crc:=UpdateCrc32(crc,b,len);
  799. {$ifdef Test_Double_checksum}
  800. if crc_only then
  801. begin
  802. crc_test2^[crc_index2]:=crc;
  803. {$ifdef Test_Double_checksum_write}
  804. Writeln(CRCFile,crc);
  805. {$endif Test_Double_checksum_write}
  806. if crc_index2<crc_array_size then
  807. inc(crc_index2);
  808. end
  809. else
  810. begin
  811. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  812. (crc_test2^[crcindex2]<>crc) then
  813. Do_comment(V_Note,'impl CRC changed');
  814. {$ifdef Test_Double_checksum_write}
  815. Writeln(CRCFile,crc);
  816. {$endif Test_Double_checksum_write}
  817. inc(crcindex2);
  818. end;
  819. {$endif def Test_Double_checksum}
  820. if do_interface_crc then
  821. begin
  822. interface_crc:=UpdateCrc32(interface_crc,b,len);
  823. {$ifdef Test_Double_checksum}
  824. if crc_only then
  825. begin
  826. crc_test^[crc_index]:=interface_crc;
  827. {$ifdef Test_Double_checksum_write}
  828. Writeln(CRCFile,interface_crc);
  829. {$endif Test_Double_checksum_write}
  830. if crc_index<crc_array_size then
  831. inc(crc_index);
  832. end
  833. else
  834. begin
  835. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  836. (crc_test^[crcindex]<>interface_crc) then
  837. Do_comment(V_Warning,'CRC changed');
  838. {$ifdef Test_Double_checksum_write}
  839. Writeln(CRCFile,interface_crc);
  840. {$endif Test_Double_checksum_write}
  841. inc(crcindex);
  842. end;
  843. {$endif def Test_Double_checksum}
  844. end;
  845. end;
  846. if not crc_only then
  847. writedata(b,len);
  848. inc(entryidx,len);
  849. end;
  850. procedure tppufile.putbyte(b:byte);
  851. begin
  852. putdata(b,1);
  853. end;
  854. procedure tppufile.putword(w:word);
  855. begin
  856. putdata(w,2);
  857. end;
  858. procedure tppufile.putlongint(l:longint);
  859. begin
  860. putdata(l,4);
  861. end;
  862. procedure tppufile.putint64(i:int64);
  863. begin
  864. putdata(i,8);
  865. end;
  866. procedure tppufile.putaint(i:aint);
  867. begin
  868. putdata(i,sizeof(aint));
  869. end;
  870. procedure tppufile.putreal(d:ppureal);
  871. begin
  872. putdata(d,sizeof(ppureal));
  873. end;
  874. procedure tppufile.putstring(s:string);
  875. begin
  876. putdata(s,length(s)+1);
  877. end;
  878. procedure tppufile.putsmallset(const b);
  879. var
  880. l : longint;
  881. begin
  882. l:=longint(b);
  883. putlongint(l);
  884. end;
  885. procedure tppufile.putnormalset(const b);
  886. type
  887. SetLongintArray = Array [0..7] of longint;
  888. var
  889. i : longint;
  890. tempb : setlongintarray;
  891. begin
  892. if change_endian then
  893. begin
  894. for i:=0 to 7 do
  895. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  896. putdata(tempb,32);
  897. end
  898. else
  899. putdata(b,32);
  900. end;
  901. procedure tppufile.tempclose;
  902. begin
  903. if not closed then
  904. begin
  905. closepos:=filepos(f);
  906. {$I-}
  907. system.close(f);
  908. {$I+}
  909. if ioresult<>0 then;
  910. closed:=true;
  911. tempclosed:=true;
  912. end;
  913. end;
  914. function tppufile.tempopen:boolean;
  915. var
  916. ofm : byte;
  917. begin
  918. tempopen:=false;
  919. if not closed or not tempclosed then
  920. exit;
  921. ofm:=filemode;
  922. filemode:=0;
  923. {$I-}
  924. reset(f,1);
  925. {$I+}
  926. filemode:=ofm;
  927. if ioresult<>0 then
  928. exit;
  929. closed:=false;
  930. tempclosed:=false;
  931. { restore state }
  932. seek(f,closepos);
  933. tempopen:=true;
  934. end;
  935. end.
  936. {
  937. $Log$
  938. Revision 1.51 2004-06-20 08:55:30 florian
  939. * logs truncated
  940. Revision 1.50 2004/06/16 20:07:09 florian
  941. * dwarf branch merged
  942. Revision 1.49 2004/05/19 21:16:13 peter
  943. * add DEBUGINFO symbol to reference the .o file that includes the
  944. stabs info for types and global/static variables
  945. * debuginfo flag added to ppu to indicate whether debuginfo is
  946. generated or not
  947. Revision 1.48 2004/04/29 19:56:37 daniel
  948. * Prepare compiler infrastructure for multiple ansistring types
  949. Revision 1.47.2.1 2004/05/01 16:02:09 peter
  950. * POINTER_SIZE replaced with sizeof(aint)
  951. * aint,aword,tconst*int moved to globtype
  952. Revision 1.47 2004/03/23 22:34:49 peter
  953. * constants ordinals now always have a type assigned
  954. * integer constants have the smallest type, unsigned prefered over
  955. signed
  956. }