ppu.pas 23 KB

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