ppu.pas 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095
  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. systems,
  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. if crc_only then
  639. exit;
  640. { flush buffer }
  641. writebuf;
  642. { update size (w/o header!) in the header }
  643. header.size:=bufstart-sizeof(tppuheader);
  644. { set the endian flag }
  645. if source_info.endian = endian_little then
  646. header.flags := header.flags or uf_little_endian
  647. else
  648. begin
  649. header.flags := header.flags or uf_big_endian;
  650. { Now swap the header in the correct endian (always little 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. end;
  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_Note,'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.36 2003-05-24 13:37:10 jonas
  882. * endian fixes
  883. Revision 1.35 2003/05/23 17:03:51 peter
  884. * write header for crc_only
  885. Revision 1.34 2003/04/25 20:59:34 peter
  886. * removed funcretn,funcretsym, function result is now in varsym
  887. and aliases for result and function name are added using absolutesym
  888. * vs_hidden parameter for funcret passed in parameter
  889. * vs_hidden fixes
  890. * writenode changed to printnode and released from extdebug
  891. * -vp option added to generate a tree.log with the nodetree
  892. * nicer printnode for statements, callnode
  893. Revision 1.33 2003/04/24 13:03:01 florian
  894. * comp is now written with its bit pattern to the ppu instead as an extended
  895. Revision 1.32 2003/04/23 14:42:07 daniel
  896. * Further register allocator work. Compiler now smaller with new
  897. allocator than without.
  898. * Somebody forgot to adjust ppu version number
  899. Revision 1.31 2003/04/10 17:57:53 peter
  900. * vs_hidden released
  901. Revision 1.30 2003/03/17 15:54:22 peter
  902. * store symoptions also for procdef
  903. * check symoptions (private,public) when calculating possible
  904. overload candidates
  905. Revision 1.29 2003/01/08 18:43:56 daniel
  906. * Tregister changed into a record
  907. Revision 1.28 2002/11/15 01:58:53 peter
  908. * merged changes from 1.0.7 up to 04-11
  909. - -V option for generating bug report tracing
  910. - more tracing for option parsing
  911. - errors for cdecl and high()
  912. - win32 import stabs
  913. - win32 records<=8 are returned in eax:edx (turned off by default)
  914. - heaptrc update
  915. - more info for temp management in .s file with EXTDEBUG
  916. Revision 1.27 2002/10/14 19:42:33 peter
  917. * only use init tables for threadvars
  918. Revision 1.26 2002/08/18 20:06:25 peter
  919. * inlining is now also allowed in interface
  920. * renamed write/load to ppuwrite/ppuload
  921. * tnode storing in ppu
  922. * nld,ncon,nbas are already updated for storing in ppu
  923. Revision 1.25 2002/08/15 19:10:35 peter
  924. * first things tai,tnode storing in ppu
  925. Revision 1.24 2002/08/15 15:09:42 carl
  926. + fpu emulation helpers (ppu checking also)
  927. Revision 1.23 2002/08/13 21:40:56 florian
  928. * more fixes for ppc calling conventions
  929. Revision 1.22 2002/08/11 13:24:12 peter
  930. * saving of asmsymbols in ppu supported
  931. * asmsymbollist global is removed and moved into a new class
  932. tasmlibrarydata that will hold the info of a .a file which
  933. corresponds with a single module. Added librarydata to tmodule
  934. to keep the library info stored for the module. In the future the
  935. objectfiles will also be stored to the tasmlibrarydata class
  936. * all getlabel/newasmsymbol and friends are moved to the new class
  937. Revision 1.21 2002/08/09 07:33:02 florian
  938. * a couple of interface related fixes
  939. Revision 1.20 2002/05/18 13:34:13 peter
  940. * readded missing revisions
  941. Revision 1.19 2002/05/16 19:46:44 carl
  942. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  943. + try to fix temp allocation (still in ifdef)
  944. + generic constructor calls
  945. + start of tassembler / tmodulebase class cleanup
  946. Revision 1.17 2002/04/04 19:06:03 peter
  947. * removed unused units
  948. * use tlocation.size in cg.a_*loc*() routines
  949. Revision 1.16 2002/03/31 20:26:36 jonas
  950. + a_loadfpu_* and a_loadmm_* methods in tcg
  951. * register allocation is now handled by a class and is mostly processor
  952. independent (+rgobj.pas and i386/rgcpu.pas)
  953. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  954. * some small improvements and fixes to the optimizer
  955. * some register allocation fixes
  956. * some fpuvaroffset fixes in the unary minus node
  957. * push/popusedregisters is now called rg.save/restoreusedregisters and
  958. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  959. also better optimizable)
  960. * fixed and optimized register saving/restoring for new/dispose nodes
  961. * LOC_FPU locations now also require their "register" field to be set to
  962. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  963. - list field removed of the tnode class because it's not used currently
  964. and can cause hard-to-find bugs
  965. Revision 1.15 2002/03/28 16:07:52 armin
  966. + initialize threadvars defined local in units
  967. }