ppu.pas 24 KB

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