ppu.pas 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Routines to read/write ppu files
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit ppu;
  19. {$i fpcdefs.inc}
  20. interface
  21. { 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=37;
  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. public
  150. crcindex,
  151. crc_index,
  152. crcindex2,
  153. crc_index2 : cardinal;
  154. crc_test,
  155. crc_test2 : pcrc_array;
  156. private
  157. {$endif def Test_Double_checksum}
  158. change_endian : boolean;
  159. buf : pchar;
  160. bufstart,
  161. bufsize,
  162. bufidx : integer;
  163. entrybufstart,
  164. entrystart,
  165. entryidx : integer;
  166. entry : tppuentry;
  167. closed,
  168. tempclosed : boolean;
  169. closepos : integer;
  170. public
  171. entrytyp : byte;
  172. header : tppuheader;
  173. size : integer;
  174. crc,
  175. interface_crc : cardinal;
  176. error,
  177. do_crc,
  178. do_interface_crc : boolean;
  179. crc_only : boolean; { used to calculate interface_crc before implementation }
  180. constructor Create(const fn:string);
  181. destructor Destroy;override;
  182. procedure flush;
  183. procedure closefile;
  184. function CheckPPUId:boolean;
  185. function GetPPUVersion:integer;
  186. procedure NewHeader;
  187. procedure NewEntry;
  188. {read}
  189. function openfile:boolean;
  190. procedure reloadbuf;
  191. procedure readdata(var b;len:integer);
  192. procedure skipdata(len:integer);
  193. function readentry:byte;
  194. function EndOfEntry:boolean;
  195. procedure getdatabuf(var b;len:integer;var res:integer);
  196. procedure getdata(var b;len:integer);
  197. function getbyte:byte;
  198. function getword:word;
  199. function getlongint:longint;
  200. function getreal:ppureal;
  201. function getstring:string;
  202. procedure getnormalset(var b);
  203. procedure getsmallset(var b);
  204. function skipuntilentry(untilb:byte):boolean;
  205. {write}
  206. function createfile:boolean;
  207. procedure writeheader;
  208. procedure writebuf;
  209. procedure writedata(const b;len:integer);
  210. procedure writeentry(ibnr:byte);
  211. procedure putdata(const b;len:integer);
  212. procedure putbyte(b:byte);
  213. procedure putword(w:word);
  214. procedure putlongint(l:longint);
  215. procedure putreal(d:ppureal);
  216. procedure putstring(s:string);
  217. procedure putnormalset(const b);
  218. procedure putsmallset(const b);
  219. procedure tempclose;
  220. function tempopen:boolean;
  221. end;
  222. implementation
  223. uses
  224. {$ifdef Test_Double_checksum}
  225. comphook,
  226. {$endif def Test_Double_checksum}
  227. crc;
  228. {*****************************************************************************
  229. Endian Handling
  230. *****************************************************************************}
  231. Function SwapLong(x : longint): longint;
  232. var
  233. y : word;
  234. z : word;
  235. Begin
  236. y := x shr 16;
  237. y := word(longint(y) shl 8) or (y shr 8);
  238. z := x and $FFFF;
  239. z := word(longint(z) shl 8) or (z shr 8);
  240. SwapLong := (longint(z) shl 16) or longint(y);
  241. End;
  242. Function SwapWord(x : word): word;
  243. var
  244. z : byte;
  245. Begin
  246. z := x shr 8;
  247. x := x and $ff;
  248. x := word(x shl 8);
  249. SwapWord := x or z;
  250. End;
  251. {*****************************************************************************
  252. TPPUFile
  253. *****************************************************************************}
  254. constructor tppufile.Create(const fn:string);
  255. begin
  256. fname:=fn;
  257. change_endian:=false;
  258. crc_only:=false;
  259. Mode:=0;
  260. NewHeader;
  261. Error:=false;
  262. closed:=true;
  263. tempclosed:=false;
  264. getmem(buf,ppubufsize);
  265. end;
  266. destructor tppufile.destroy;
  267. begin
  268. closefile;
  269. if assigned(buf) then
  270. freemem(buf,ppubufsize);
  271. end;
  272. procedure tppufile.flush;
  273. begin
  274. if Mode=2 then
  275. writebuf;
  276. end;
  277. procedure tppufile.closefile;
  278. begin
  279. {$ifdef Test_Double_checksum}
  280. if mode=2 then
  281. begin
  282. if assigned(crc_test) then
  283. dispose(crc_test);
  284. if assigned(crc_test2) then
  285. dispose(crc_test2);
  286. end;
  287. {$endif Test_Double_checksum}
  288. if Mode<>0 then
  289. begin
  290. Flush;
  291. {$I-}
  292. system.close(f);
  293. {$I+}
  294. if ioresult<>0 then;
  295. Mode:=0;
  296. closed:=true;
  297. end;
  298. end;
  299. function tppufile.CheckPPUId:boolean;
  300. begin
  301. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  302. end;
  303. function tppufile.GetPPUVersion:integer;
  304. var
  305. l : integer;
  306. code : integer;
  307. begin
  308. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  309. if code=0 then
  310. GetPPUVersion:=l
  311. else
  312. GetPPUVersion:=0;
  313. end;
  314. procedure tppufile.NewHeader;
  315. var
  316. s : string;
  317. begin
  318. fillchar(header,sizeof(tppuheader),0);
  319. str(currentppuversion,s);
  320. while length(s)<3 do
  321. s:='0'+s;
  322. with header do
  323. begin
  324. Id[1]:='P';
  325. Id[2]:='P';
  326. Id[3]:='U';
  327. Ver[1]:=s[1];
  328. Ver[2]:=s[2];
  329. Ver[3]:=s[3];
  330. end;
  331. end;
  332. {*****************************************************************************
  333. TPPUFile Reading
  334. *****************************************************************************}
  335. function tppufile.openfile:boolean;
  336. var
  337. ofmode : byte;
  338. i : integer;
  339. begin
  340. openfile:=false;
  341. assign(f,fname);
  342. ofmode:=filemode;
  343. filemode:=$0;
  344. {$I-}
  345. reset(f,1);
  346. {$I+}
  347. filemode:=ofmode;
  348. if ioresult<>0 then
  349. exit;
  350. closed:=false;
  351. {read ppuheader}
  352. fsize:=filesize(f);
  353. if fsize<sizeof(tppuheader) then
  354. exit;
  355. blockread(f,header,sizeof(tppuheader),i);
  356. { The header is always stored in little endian order }
  357. { therefore swap if on a big endian machine }
  358. {$IFDEF ENDIAN_BIG}
  359. header.compiler := SwapWord(header.compiler);
  360. header.cpu := SwapWord(header.cpu);
  361. header.target := SwapWord(header.target);
  362. header.flags := SwapLong(header.flags);
  363. header.size := SwapLong(header.size);
  364. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  365. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  366. {$ENDIF}
  367. { the PPU DATA is stored in native order }
  368. if (header.flags and uf_big_endian) = uf_big_endian then
  369. Begin
  370. {$IFDEF ENDIAN_LITTLE}
  371. change_endian := TRUE;
  372. {$ELSE}
  373. change_endian := FALSE;
  374. {$ENDIF}
  375. End
  376. else if (header.flags and uf_little_endian) = uf_little_endian then
  377. Begin
  378. {$IFDEF ENDIAN_BIG}
  379. change_endian := TRUE;
  380. {$ELSE}
  381. change_endian := FALSE;
  382. {$ENDIF}
  383. End;
  384. {reset buffer}
  385. bufstart:=i;
  386. bufsize:=0;
  387. bufidx:=0;
  388. Mode:=1;
  389. FillChar(entry,sizeof(tppuentry),0);
  390. entryidx:=0;
  391. entrystart:=0;
  392. entrybufstart:=0;
  393. Error:=false;
  394. openfile:=true;
  395. end;
  396. procedure tppufile.reloadbuf;
  397. begin
  398. inc(bufstart,bufsize);
  399. blockread(f,buf^,ppubufsize,bufsize);
  400. bufidx:=0;
  401. end;
  402. procedure tppufile.readdata(var b;len:integer);
  403. var
  404. p : pchar;
  405. left,
  406. idx : integer;
  407. begin
  408. p:=pchar(@b);
  409. idx:=0;
  410. while len>0 do
  411. begin
  412. left:=bufsize-bufidx;
  413. if len>left then
  414. begin
  415. move(buf[bufidx],p[idx],left);
  416. dec(len,left);
  417. inc(idx,left);
  418. reloadbuf;
  419. if bufsize=0 then
  420. exit;
  421. end
  422. else
  423. begin
  424. move(buf[bufidx],p[idx],len);
  425. inc(bufidx,len);
  426. exit;
  427. end;
  428. end;
  429. end;
  430. procedure tppufile.skipdata(len:integer);
  431. var
  432. left : integer;
  433. begin
  434. while len>0 do
  435. begin
  436. left:=bufsize-bufidx;
  437. if len>left then
  438. begin
  439. dec(len,left);
  440. reloadbuf;
  441. if bufsize=0 then
  442. exit;
  443. end
  444. else
  445. begin
  446. inc(bufidx,len);
  447. exit;
  448. end;
  449. end;
  450. end;
  451. function tppufile.readentry:byte;
  452. begin
  453. if entryidx<entry.size then
  454. skipdata(entry.size-entryidx);
  455. readdata(entry,sizeof(tppuentry));
  456. entrystart:=bufstart+bufidx;
  457. entryidx:=0;
  458. if not(entry.id in [mainentryid,subentryid]) then
  459. begin
  460. readentry:=iberror;
  461. error:=true;
  462. exit;
  463. end;
  464. readentry:=entry.nr;
  465. end;
  466. function tppufile.endofentry:boolean;
  467. begin
  468. endofentry:=(entryidx>=entry.size);
  469. end;
  470. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  471. begin
  472. if entryidx+len>entry.size then
  473. res:=entry.size-entryidx
  474. else
  475. res:=len;
  476. readdata(b,res);
  477. inc(entryidx,res);
  478. end;
  479. procedure tppufile.getdata(var b;len:integer);
  480. begin
  481. if entryidx+len>entry.size then
  482. begin
  483. error:=true;
  484. exit;
  485. end;
  486. readdata(b,len);
  487. inc(entryidx,len);
  488. end;
  489. function tppufile.getbyte:byte;
  490. var
  491. b : byte;
  492. begin
  493. if entryidx+1>entry.size then
  494. begin
  495. error:=true;
  496. getbyte:=0;
  497. exit;
  498. end;
  499. readdata(b,1);
  500. getbyte:=b;
  501. inc(entryidx);
  502. end;
  503. function tppufile.getword:word;
  504. var
  505. w : word;
  506. begin
  507. if entryidx+2>entry.size then
  508. begin
  509. error:=true;
  510. getword:=0;
  511. exit;
  512. end;
  513. readdata(w,2);
  514. if change_endian then
  515. getword:=swapword(w)
  516. else
  517. getword:=w;
  518. inc(entryidx,2);
  519. end;
  520. function tppufile.getlongint:longint;
  521. var
  522. l : longint;
  523. begin
  524. if entryidx+4>entry.size then
  525. begin
  526. error:=true;
  527. getlongint:=0;
  528. exit;
  529. end;
  530. readdata(l,4);
  531. if change_endian then
  532. getlongint:=swaplong(l)
  533. else
  534. getlongint:=l;
  535. inc(entryidx,4);
  536. end;
  537. function tppufile.getreal:ppureal;
  538. var
  539. d : ppureal;
  540. begin
  541. if entryidx+sizeof(ppureal)>entry.size then
  542. begin
  543. error:=true;
  544. getreal:=0;
  545. exit;
  546. end;
  547. readdata(d,sizeof(ppureal));
  548. getreal:=d;
  549. inc(entryidx,sizeof(ppureal));
  550. end;
  551. function tppufile.getstring:string;
  552. var
  553. s : string;
  554. begin
  555. s[0]:=chr(getbyte);
  556. if entryidx+length(s)>entry.size then
  557. begin
  558. error:=true;
  559. exit;
  560. end;
  561. ReadData(s[1],length(s));
  562. getstring:=s;
  563. inc(entryidx,length(s));
  564. end;
  565. procedure tppufile.getsmallset(var b);
  566. var
  567. l : longint;
  568. begin
  569. l:=getlongint;
  570. longint(b):=l;
  571. end;
  572. procedure tppufile.getnormalset(var b);
  573. type
  574. SetLongintArray = Array [0..7] of longint;
  575. var
  576. i : longint;
  577. begin
  578. if change_endian then
  579. begin
  580. for i:=0 to 7 do
  581. SetLongintArray(b)[i]:=getlongint;
  582. end
  583. else
  584. getdata(b,32);
  585. end;
  586. function tppufile.skipuntilentry(untilb:byte):boolean;
  587. var
  588. b : byte;
  589. begin
  590. repeat
  591. b:=readentry;
  592. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  593. skipuntilentry:=(b=untilb);
  594. end;
  595. {*****************************************************************************
  596. TPPUFile Writing
  597. *****************************************************************************}
  598. function tppufile.createfile:boolean;
  599. begin
  600. createfile:=false;
  601. {$ifdef INTFPPU}
  602. if crc_only then
  603. begin
  604. fname:=fname+'.intf';
  605. crc_only:=false;
  606. end;
  607. {$endif}
  608. if not crc_only then
  609. begin
  610. assign(f,fname);
  611. {$I-}
  612. rewrite(f,1);
  613. {$I+}
  614. if ioresult<>0 then
  615. exit;
  616. Mode:=2;
  617. {write header for sure}
  618. blockwrite(f,header,sizeof(tppuheader));
  619. end;
  620. bufsize:=ppubufsize;
  621. bufstart:=sizeof(tppuheader);
  622. bufidx:=0;
  623. {reset}
  624. crc:=cardinal($ffffffff);
  625. interface_crc:=cardinal($ffffffff);
  626. do_interface_crc:=true;
  627. Error:=false;
  628. do_crc:=true;
  629. size:=0;
  630. entrytyp:=mainentryid;
  631. {start}
  632. NewEntry;
  633. createfile:=true;
  634. end;
  635. procedure tppufile.writeheader;
  636. var
  637. opos : integer;
  638. begin
  639. if crc_only then
  640. exit;
  641. { flush buffer }
  642. writebuf;
  643. { update size (w/o header!) in the header }
  644. header.size:=bufstart-sizeof(tppuheader);
  645. { set the endian flag }
  646. {$ifndef FPC_BIG_ENDIAN}
  647. header.flags := header.flags or uf_little_endian;
  648. {$else not FPC_BIG_ENDIAN}
  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 := cardinal(SwapLong(longint(header.checksum)));
  657. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  658. {$endif not FPC_BIG_ENDIAN}
  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.42 2003-09-23 17:56:05 peter
  882. * locals and paras are allocated in the code generation
  883. * tvarsym.localloc contains the location of para/local when
  884. generating code for the current procedure
  885. Revision 1.41 2003/07/05 20:06:28 jonas
  886. * fixed some range check errors that occurred on big endian systems
  887. * slightly optimized the swap*() functions
  888. Revision 1.40 2003/06/17 16:34:44 jonas
  889. * lots of newra fixes (need getfuncretparaloc implementation for i386)!
  890. * renamed all_intregisters to volatile_intregisters and made it
  891. processor dependent
  892. Revision 1.39 2003/06/07 20:26:32 peter
  893. * re-resolving added instead of reloading from ppu
  894. * tderef object added to store deref info for resolving
  895. Revision 1.38 2003/05/26 19:39:51 peter
  896. * removed systems unit
  897. Revision 1.37 2003/05/26 15:49:54 jonas
  898. * endian fix is now done using a define instead of with source_info
  899. Revision 1.36 2003/05/24 13:37:10 jonas
  900. * endian fixes
  901. Revision 1.35 2003/05/23 17:03:51 peter
  902. * write header for crc_only
  903. Revision 1.34 2003/04/25 20:59:34 peter
  904. * removed funcretn,funcretsym, function result is now in varsym
  905. and aliases for result and function name are added using absolutesym
  906. * vs_hidden parameter for funcret passed in parameter
  907. * vs_hidden fixes
  908. * writenode changed to printnode and released from extdebug
  909. * -vp option added to generate a tree.log with the nodetree
  910. * nicer printnode for statements, callnode
  911. Revision 1.33 2003/04/24 13:03:01 florian
  912. * comp is now written with its bit pattern to the ppu instead as an extended
  913. Revision 1.32 2003/04/23 14:42:07 daniel
  914. * Further register allocator work. Compiler now smaller with new
  915. allocator than without.
  916. * Somebody forgot to adjust ppu version number
  917. Revision 1.31 2003/04/10 17:57:53 peter
  918. * vs_hidden released
  919. Revision 1.30 2003/03/17 15:54:22 peter
  920. * store symoptions also for procdef
  921. * check symoptions (private,public) when calculating possible
  922. overload candidates
  923. Revision 1.29 2003/01/08 18:43:56 daniel
  924. * Tregister changed into a record
  925. Revision 1.28 2002/11/15 01:58:53 peter
  926. * merged changes from 1.0.7 up to 04-11
  927. - -V option for generating bug report tracing
  928. - more tracing for option parsing
  929. - errors for cdecl and high()
  930. - win32 import stabs
  931. - win32 records<=8 are returned in eax:edx (turned off by default)
  932. - heaptrc update
  933. - more info for temp management in .s file with EXTDEBUG
  934. Revision 1.27 2002/10/14 19:42:33 peter
  935. * only use init tables for threadvars
  936. Revision 1.26 2002/08/18 20:06:25 peter
  937. * inlining is now also allowed in interface
  938. * renamed write/load to ppuwrite/ppuload
  939. * tnode storing in ppu
  940. * nld,ncon,nbas are already updated for storing in ppu
  941. Revision 1.25 2002/08/15 19:10:35 peter
  942. * first things tai,tnode storing in ppu
  943. Revision 1.24 2002/08/15 15:09:42 carl
  944. + fpu emulation helpers (ppu checking also)
  945. Revision 1.23 2002/08/13 21:40:56 florian
  946. * more fixes for ppc calling conventions
  947. Revision 1.22 2002/08/11 13:24:12 peter
  948. * saving of asmsymbols in ppu supported
  949. * asmsymbollist global is removed and moved into a new class
  950. tasmlibrarydata that will hold the info of a .a file which
  951. corresponds with a single module. Added librarydata to tmodule
  952. to keep the library info stored for the module. In the future the
  953. objectfiles will also be stored to the tasmlibrarydata class
  954. * all getlabel/newasmsymbol and friends are moved to the new class
  955. Revision 1.21 2002/08/09 07:33:02 florian
  956. * a couple of interface related fixes
  957. Revision 1.20 2002/05/18 13:34:13 peter
  958. * readded missing revisions
  959. Revision 1.19 2002/05/16 19:46:44 carl
  960. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  961. + try to fix temp allocation (still in ifdef)
  962. + generic constructor calls
  963. + start of tassembler / tmodulebase class cleanup
  964. Revision 1.17 2002/04/04 19:06:03 peter
  965. * removed unused units
  966. * use tlocation.size in cg.a_*loc*() routines
  967. Revision 1.16 2002/03/31 20:26:36 jonas
  968. + a_loadfpu_* and a_loadmm_* methods in tcg
  969. * register allocation is now handled by a class and is mostly processor
  970. independent (+rgobj.pas and i386/rgcpu.pas)
  971. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  972. * some small improvements and fixes to the optimizer
  973. * some register allocation fixes
  974. * some fpuvaroffset fixes in the unary minus node
  975. * push/popusedregisters is now called rg.save/restoreusedregisters and
  976. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  977. also better optimizable)
  978. * fixed and optimized register saving/restoring for new/dispose nodes
  979. * LOC_FPU locations now also require their "register" field to be set to
  980. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  981. - list field removed of the tnode class because it's not used currently
  982. and can cause hard-to-find bugs
  983. Revision 1.15 2002/03/28 16:07:52 armin
  984. + initialize threadvars defined local in units
  985. }