ppu.pas 26 KB

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