ppu.pas 24 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123
  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. uf_uses_variants = $40000; { this unit uses variants }
  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. 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. if change_endian then
  477. entry.size:=swaplong(entry.size);
  478. entrystart:=bufstart+bufidx;
  479. entryidx:=0;
  480. if not(entry.id in [mainentryid,subentryid]) then
  481. begin
  482. readentry:=iberror;
  483. error:=true;
  484. exit;
  485. end;
  486. readentry:=entry.nr;
  487. end;
  488. function tppufile.endofentry:boolean;
  489. begin
  490. endofentry:=(entryidx>=entry.size);
  491. end;
  492. function tppufile.entrysize:longint;
  493. begin
  494. entrysize:=entry.size;
  495. end;
  496. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  497. begin
  498. if entryidx+len>entry.size then
  499. res:=entry.size-entryidx
  500. else
  501. res:=len;
  502. readdata(b,res);
  503. inc(entryidx,res);
  504. end;
  505. procedure tppufile.getdata(var b;len:integer);
  506. begin
  507. if entryidx+len>entry.size then
  508. begin
  509. error:=true;
  510. exit;
  511. end;
  512. readdata(b,len);
  513. inc(entryidx,len);
  514. end;
  515. function tppufile.getbyte:byte;
  516. var
  517. b : byte;
  518. begin
  519. if entryidx+1>entry.size then
  520. begin
  521. error:=true;
  522. getbyte:=0;
  523. exit;
  524. end;
  525. readdata(b,1);
  526. getbyte:=b;
  527. inc(entryidx);
  528. end;
  529. function tppufile.getword:word;
  530. var
  531. w : word;
  532. begin
  533. if entryidx+2>entry.size then
  534. begin
  535. error:=true;
  536. getword:=0;
  537. exit;
  538. end;
  539. readdata(w,2);
  540. if change_endian then
  541. getword:=swapword(w)
  542. else
  543. getword:=w;
  544. inc(entryidx,2);
  545. end;
  546. function tppufile.getlongint:longint;
  547. var
  548. l : longint;
  549. begin
  550. if entryidx+4>entry.size then
  551. begin
  552. error:=true;
  553. getlongint:=0;
  554. exit;
  555. end;
  556. readdata(l,4);
  557. if change_endian then
  558. getlongint:=swaplong(l)
  559. else
  560. getlongint:=l;
  561. inc(entryidx,4);
  562. end;
  563. function tppufile.getint64:int64;
  564. var
  565. i : int64;
  566. begin
  567. if entryidx+8>entry.size then
  568. begin
  569. error:=true;
  570. result:=0;
  571. exit;
  572. end;
  573. readdata(i,8);
  574. if change_endian then
  575. result:=swapint64(i)
  576. else
  577. result:=i;
  578. inc(entryidx,8);
  579. end;
  580. function tppufile.getaint:aint;
  581. begin
  582. {$ifdef cpu64bit}
  583. result:=getint64;
  584. {$else cpu64bit}
  585. result:=getlongint;
  586. {$endif cpu64bit}
  587. end;
  588. function tppufile.getreal:ppureal;
  589. var
  590. d : ppureal;
  591. begin
  592. if entryidx+sizeof(ppureal)>entry.size then
  593. begin
  594. error:=true;
  595. getreal:=0;
  596. exit;
  597. end;
  598. readdata(d,sizeof(ppureal));
  599. getreal:=d;
  600. inc(entryidx,sizeof(ppureal));
  601. end;
  602. function tppufile.getstring:string;
  603. var
  604. s : string;
  605. begin
  606. s[0]:=chr(getbyte);
  607. if entryidx+length(s)>entry.size then
  608. begin
  609. error:=true;
  610. exit;
  611. end;
  612. ReadData(s[1],length(s));
  613. getstring:=s;
  614. inc(entryidx,length(s));
  615. end;
  616. procedure tppufile.getsmallset(var b);
  617. var
  618. l : longint;
  619. begin
  620. l:=getlongint;
  621. longint(b):=l;
  622. end;
  623. procedure tppufile.getnormalset(var b);
  624. type
  625. SetLongintArray = Array [0..7] of longint;
  626. var
  627. i : longint;
  628. begin
  629. if change_endian then
  630. begin
  631. for i:=0 to 7 do
  632. SetLongintArray(b)[i]:=getlongint;
  633. end
  634. else
  635. getdata(b,32);
  636. end;
  637. function tppufile.skipuntilentry(untilb:byte):boolean;
  638. var
  639. b : byte;
  640. begin
  641. repeat
  642. b:=readentry;
  643. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  644. skipuntilentry:=(b=untilb);
  645. end;
  646. {*****************************************************************************
  647. TPPUFile Writing
  648. *****************************************************************************}
  649. function tppufile.createfile:boolean;
  650. begin
  651. createfile:=false;
  652. {$ifdef INTFPPU}
  653. if crc_only then
  654. begin
  655. fname:=fname+'.intf';
  656. crc_only:=false;
  657. end;
  658. {$endif}
  659. if not crc_only then
  660. begin
  661. assign(f,fname);
  662. {$I-}
  663. rewrite(f,1);
  664. {$I+}
  665. if ioresult<>0 then
  666. exit;
  667. Mode:=2;
  668. {write header for sure}
  669. blockwrite(f,header,sizeof(tppuheader));
  670. end;
  671. bufsize:=ppubufsize;
  672. bufstart:=sizeof(tppuheader);
  673. bufidx:=0;
  674. {reset}
  675. crc:=cardinal($ffffffff);
  676. interface_crc:=cardinal($ffffffff);
  677. do_interface_crc:=true;
  678. Error:=false;
  679. do_crc:=true;
  680. size:=0;
  681. entrytyp:=mainentryid;
  682. {start}
  683. NewEntry;
  684. createfile:=true;
  685. end;
  686. procedure tppufile.writeheader;
  687. var
  688. opos : integer;
  689. begin
  690. if crc_only then
  691. exit;
  692. { flush buffer }
  693. writebuf;
  694. { update size (w/o header!) in the header }
  695. header.size:=bufstart-sizeof(tppuheader);
  696. { set the endian flag }
  697. {$ifndef FPC_BIG_ENDIAN}
  698. header.flags := header.flags or uf_little_endian;
  699. {$else not FPC_BIG_ENDIAN}
  700. header.flags := header.flags or uf_big_endian;
  701. { Now swap the header in the correct endian (always little endian) }
  702. header.compiler := SwapWord(header.compiler);
  703. header.cpu := SwapWord(header.cpu);
  704. header.target := SwapWord(header.target);
  705. header.flags := SwapLong(header.flags);
  706. header.size := SwapLong(header.size);
  707. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  708. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  709. {$endif not FPC_BIG_ENDIAN}
  710. { write header and restore filepos after it }
  711. opos:=filepos(f);
  712. seek(f,0);
  713. blockwrite(f,header,sizeof(tppuheader));
  714. seek(f,opos);
  715. end;
  716. procedure tppufile.writebuf;
  717. begin
  718. if not crc_only then
  719. blockwrite(f,buf^,bufidx);
  720. inc(bufstart,bufidx);
  721. bufidx:=0;
  722. end;
  723. procedure tppufile.writedata(const b;len:integer);
  724. var
  725. p : pchar;
  726. left,
  727. idx : integer;
  728. begin
  729. if crc_only then
  730. exit;
  731. p:=pchar(@b);
  732. idx:=0;
  733. while len>0 do
  734. begin
  735. left:=bufsize-bufidx;
  736. if len>left then
  737. begin
  738. move(p[idx],buf[bufidx],left);
  739. dec(len,left);
  740. inc(idx,left);
  741. inc(bufidx,left);
  742. writebuf;
  743. end
  744. else
  745. begin
  746. move(p[idx],buf[bufidx],len);
  747. inc(bufidx,len);
  748. exit;
  749. end;
  750. end;
  751. end;
  752. procedure tppufile.NewEntry;
  753. begin
  754. with entry do
  755. begin
  756. id:=entrytyp;
  757. nr:=ibend;
  758. size:=0;
  759. end;
  760. {Reset Entry State}
  761. entryidx:=0;
  762. entrybufstart:=bufstart;
  763. entrystart:=bufstart+bufidx;
  764. {Alloc in buffer}
  765. writedata(entry,sizeof(tppuentry));
  766. end;
  767. procedure tppufile.writeentry(ibnr:byte);
  768. var
  769. opos : integer;
  770. begin
  771. {create entry}
  772. entry.id:=entrytyp;
  773. entry.nr:=ibnr;
  774. entry.size:=entryidx;
  775. {it's already been sent to disk ?}
  776. if entrybufstart<>bufstart then
  777. begin
  778. if not crc_only then
  779. begin
  780. {flush to be sure}
  781. WriteBuf;
  782. {write entry}
  783. opos:=filepos(f);
  784. seek(f,entrystart);
  785. blockwrite(f,entry,sizeof(tppuentry));
  786. seek(f,opos);
  787. end;
  788. entrybufstart:=bufstart;
  789. end
  790. else
  791. move(entry,buf[entrystart-bufstart],sizeof(entry));
  792. {Add New Entry, which is ibend by default}
  793. entrystart:=bufstart+bufidx; {next entry position}
  794. NewEntry;
  795. end;
  796. procedure tppufile.putdata(const b;len:integer);
  797. begin
  798. if do_crc then
  799. begin
  800. crc:=UpdateCrc32(crc,b,len);
  801. {$ifdef Test_Double_checksum}
  802. if crc_only then
  803. begin
  804. crc_test2^[crc_index2]:=crc;
  805. {$ifdef Test_Double_checksum_write}
  806. Writeln(CRCFile,crc);
  807. {$endif Test_Double_checksum_write}
  808. if crc_index2<crc_array_size then
  809. inc(crc_index2);
  810. end
  811. else
  812. begin
  813. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  814. (crc_test2^[crcindex2]<>crc) then
  815. Do_comment(V_Note,'impl CRC changed');
  816. {$ifdef Test_Double_checksum_write}
  817. Writeln(CRCFile,crc);
  818. {$endif Test_Double_checksum_write}
  819. inc(crcindex2);
  820. end;
  821. {$endif def Test_Double_checksum}
  822. if do_interface_crc then
  823. begin
  824. interface_crc:=UpdateCrc32(interface_crc,b,len);
  825. {$ifdef Test_Double_checksum}
  826. if crc_only then
  827. begin
  828. crc_test^[crc_index]:=interface_crc;
  829. {$ifdef Test_Double_checksum_write}
  830. Writeln(CRCFile,interface_crc);
  831. {$endif Test_Double_checksum_write}
  832. if crc_index<crc_array_size then
  833. inc(crc_index);
  834. end
  835. else
  836. begin
  837. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  838. (crc_test^[crcindex]<>interface_crc) then
  839. Do_comment(V_Warning,'CRC changed');
  840. {$ifdef Test_Double_checksum_write}
  841. Writeln(CRCFile,interface_crc);
  842. {$endif Test_Double_checksum_write}
  843. inc(crcindex);
  844. end;
  845. {$endif def Test_Double_checksum}
  846. end;
  847. end;
  848. if not crc_only then
  849. writedata(b,len);
  850. inc(entryidx,len);
  851. end;
  852. procedure tppufile.putbyte(b:byte);
  853. begin
  854. putdata(b,1);
  855. end;
  856. procedure tppufile.putword(w:word);
  857. begin
  858. putdata(w,2);
  859. end;
  860. procedure tppufile.putlongint(l:longint);
  861. begin
  862. putdata(l,4);
  863. end;
  864. procedure tppufile.putint64(i:int64);
  865. begin
  866. putdata(i,8);
  867. end;
  868. procedure tppufile.putaint(i:aint);
  869. begin
  870. putdata(i,sizeof(aint));
  871. end;
  872. procedure tppufile.putreal(d:ppureal);
  873. begin
  874. putdata(d,sizeof(ppureal));
  875. end;
  876. procedure tppufile.putstring(s:string);
  877. begin
  878. putdata(s,length(s)+1);
  879. end;
  880. procedure tppufile.putsmallset(const b);
  881. var
  882. l : longint;
  883. begin
  884. l:=longint(b);
  885. putlongint(l);
  886. end;
  887. procedure tppufile.putnormalset(const b);
  888. type
  889. SetLongintArray = Array [0..7] of longint;
  890. var
  891. i : longint;
  892. tempb : setlongintarray;
  893. begin
  894. if change_endian then
  895. begin
  896. for i:=0 to 7 do
  897. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  898. putdata(tempb,32);
  899. end
  900. else
  901. putdata(b,32);
  902. end;
  903. procedure tppufile.tempclose;
  904. begin
  905. if not closed then
  906. begin
  907. closepos:=filepos(f);
  908. {$I-}
  909. system.close(f);
  910. {$I+}
  911. if ioresult<>0 then;
  912. closed:=true;
  913. tempclosed:=true;
  914. end;
  915. end;
  916. function tppufile.tempopen:boolean;
  917. var
  918. ofm : byte;
  919. begin
  920. tempopen:=false;
  921. if not closed or not tempclosed then
  922. exit;
  923. ofm:=filemode;
  924. filemode:=0;
  925. {$I-}
  926. reset(f,1);
  927. {$I+}
  928. filemode:=ofm;
  929. if ioresult<>0 then
  930. exit;
  931. closed:=false;
  932. tempclosed:=false;
  933. { restore state }
  934. seek(f,closepos);
  935. tempopen:=true;
  936. end;
  937. end.
  938. {
  939. $Log$
  940. Revision 1.60 2004-12-06 19:23:05 peter
  941. implicit load of variants unit
  942. Revision 1.59 2004/11/15 23:35:31 peter
  943. * tparaitem removed, use tparavarsym instead
  944. * parameter order is now calculated from paranr value in tparavarsym
  945. Revision 1.58 2004/11/08 22:09:59 peter
  946. * tvarsym splitted
  947. Revision 1.57 2004/09/21 17:25:12 peter
  948. * paraloc branch merged
  949. Revision 1.56.4.1 2004/09/12 14:01:23 peter
  950. * entry.size need endian update
  951. Revision 1.56 2004/08/27 21:59:26 peter
  952. browser disabled
  953. uf_local_symtable ppu flag when a localsymtable is stored
  954. Revision 1.55 2004/08/22 20:11:38 florian
  955. * morphos now takes any pointer var. as libbase
  956. * alignment for sparc fixed
  957. * int -> double conversion on sparc fixed
  958. Revision 1.54 2004/08/17 16:29:21 jonas
  959. + padalgingment field for recordsymtables (saved by recorddefs)
  960. + support for Macintosh PowerPC alignment (if the first field of a record
  961. or union has an alignment > 4, then the record or union size must be
  962. padded to a multiple of this size)
  963. Revision 1.53 2004/07/12 09:14:04 jonas
  964. * inline procedures at the node tree level, but only under some very
  965. limited circumstances for now (only procedures, and only if they have
  966. no or only vs_out/vs_var parameters).
  967. * fixed ppudump for inline procedures
  968. * fixed ppudump for ppc
  969. Revision 1.52 2004/07/09 23:11:05 peter
  970. * new format
  971. Revision 1.51 2004/06/20 08:55:30 florian
  972. * logs truncated
  973. Revision 1.50 2004/06/16 20:07:09 florian
  974. * dwarf branch merged
  975. Revision 1.49 2004/05/19 21:16:13 peter
  976. * add DEBUGINFO symbol to reference the .o file that includes the
  977. stabs info for types and global/static variables
  978. * debuginfo flag added to ppu to indicate whether debuginfo is
  979. generated or not
  980. Revision 1.48 2004/04/29 19:56:37 daniel
  981. * Prepare compiler infrastructure for multiple ansistring types
  982. Revision 1.47.2.1 2004/05/01 16:02:09 peter
  983. * POINTER_SIZE replaced with sizeof(aint)
  984. * aint,aword,tconst*int moved to globtype
  985. Revision 1.47 2004/03/23 22:34:49 peter
  986. * constants ordinals now always have a type assigned
  987. * integer constants have the smallest type, unsigned prefered over
  988. signed
  989. }