ppu.pas 24 KB

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