ppu.pas 23 KB

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