ppu.pas 25 KB

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