ppu.pas 24 KB

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