ppu.pas 27 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198
  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. uses
  22. cpuinfo;
  23. { Also write the ppu if only crc if done, this can be used with ppudump to
  24. see the differences between the intf and implementation }
  25. { define INTFPPU}
  26. {$ifdef Test_Double_checksum}
  27. var
  28. CRCFile : text;
  29. const
  30. CRC_array_Size = 200000;
  31. type
  32. tcrc_array = array[0..crc_array_size] of longint;
  33. pcrc_array = ^tcrc_array;
  34. {$endif Test_Double_checksum}
  35. const
  36. CurrentPPUVersion=40;
  37. { buffer sizes }
  38. maxentrysize = 1024;
  39. ppubufsize = 16384;
  40. {ppu entries}
  41. mainentryid = 1;
  42. subentryid = 2;
  43. {special}
  44. iberror = 0;
  45. ibstartdefs = 248;
  46. ibenddefs = 249;
  47. ibstartsyms = 250;
  48. ibendsyms = 251;
  49. ibendinterface = 252;
  50. ibendimplementation = 253;
  51. ibendbrowser = 254;
  52. ibend = 255;
  53. {general}
  54. ibmodulename = 1;
  55. ibsourcefiles = 2;
  56. ibloadunit = 3;
  57. ibinitunit = 4;
  58. iblinkunitofiles = 5;
  59. iblinkunitstaticlibs = 6;
  60. iblinkunitsharedlibs = 7;
  61. iblinkotherofiles = 8;
  62. iblinkotherstaticlibs = 9;
  63. iblinkothersharedlibs = 10;
  64. ibdbxcount = 11;
  65. ibsymref = 12;
  66. ibdefref = 13;
  67. ibendsymtablebrowser = 14;
  68. ibbeginsymtablebrowser = 15;
  69. ibusedmacros = 16;
  70. ibderefdata = 17;
  71. {syms}
  72. ibtypesym = 20;
  73. ibprocsym = 21;
  74. ibvarsym = 22;
  75. ibconstsym = 23;
  76. ibenumsym = 24;
  77. ibtypedconstsym = 25;
  78. ibabsolutesym = 26;
  79. ibpropertysym = 27;
  80. ibvarsym_C = 28;
  81. ibunitsym = 29; { needed for browser }
  82. iblabelsym = 30;
  83. ibsyssym = 31;
  84. ibrttisym = 32;
  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. {implementation/objectdata}
  105. ibnodetree = 80;
  106. ibasmsymbols = 81;
  107. { unit flags }
  108. uf_init = $1;
  109. uf_finalize = $2;
  110. uf_big_endian = $4;
  111. uf_has_dbx = $8;
  112. uf_has_browser = $10;
  113. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  114. uf_smart_linked = $40; { the ppu can be smartlinked }
  115. uf_static_linked = $80; { the ppu can be linked static }
  116. uf_shared_linked = $100; { the ppu can be linked shared }
  117. uf_local_browser = $200;
  118. uf_no_link = $400; { unit has no .o generated, but can still have
  119. external linking! }
  120. uf_has_resources = $800; { unit has resource section }
  121. uf_little_endian = $1000;
  122. uf_release = $2000; { unit was compiled with -Ur option }
  123. uf_threadvars = $4000; { unit has threadvars }
  124. uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
  125. type
  126. ppureal=extended;
  127. tppuerror=(ppuentrytoobig,ppuentryerror);
  128. tppuheader=packed record { 36 bytes }
  129. id : array[1..3] of char; { = 'PPU' }
  130. ver : array[1..3] of char;
  131. compiler : word;
  132. cpu : word;
  133. target : word;
  134. flags : longint;
  135. size : longint; { size of the ppufile without header }
  136. checksum : cardinal; { checksum for this ppufile }
  137. interface_checksum : cardinal;
  138. future : array[0..2] of longint;
  139. end;
  140. tppuentry=packed record
  141. size : longint;
  142. id : byte;
  143. nr : byte;
  144. end;
  145. tppufile=class
  146. private
  147. f : file;
  148. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  149. fname : string;
  150. fsize : integer;
  151. {$ifdef Test_Double_checksum}
  152. public
  153. crcindex,
  154. crc_index,
  155. crcindex2,
  156. crc_index2 : cardinal;
  157. crc_test,
  158. crc_test2 : pcrc_array;
  159. private
  160. {$endif def Test_Double_checksum}
  161. change_endian : boolean;
  162. buf : pchar;
  163. bufstart,
  164. bufsize,
  165. bufidx : integer;
  166. entrybufstart,
  167. entrystart,
  168. entryidx : integer;
  169. entry : tppuentry;
  170. closed,
  171. tempclosed : boolean;
  172. closepos : integer;
  173. public
  174. entrytyp : byte;
  175. header : tppuheader;
  176. size : integer;
  177. crc,
  178. interface_crc : cardinal;
  179. error,
  180. do_crc,
  181. do_interface_crc : boolean;
  182. crc_only : boolean; { used to calculate interface_crc before implementation }
  183. constructor Create(const fn:string);
  184. destructor Destroy;override;
  185. procedure flush;
  186. procedure closefile;
  187. function CheckPPUId:boolean;
  188. function GetPPUVersion:integer;
  189. procedure NewHeader;
  190. procedure NewEntry;
  191. {read}
  192. function openfile:boolean;
  193. procedure reloadbuf;
  194. procedure readdata(var b;len:integer);
  195. procedure skipdata(len:integer);
  196. function readentry:byte;
  197. function EndOfEntry:boolean;
  198. function entrysize:longint;
  199. procedure getdatabuf(var b;len:integer;var res:integer);
  200. procedure getdata(var b;len:integer);
  201. function getbyte:byte;
  202. function getword:word;
  203. function getlongint:longint;
  204. function getint64:int64;
  205. function getaint:aint;
  206. function getreal:ppureal;
  207. function getstring:string;
  208. procedure getnormalset(var b);
  209. procedure getsmallset(var b);
  210. function skipuntilentry(untilb:byte):boolean;
  211. {write}
  212. function createfile:boolean;
  213. procedure writeheader;
  214. procedure writebuf;
  215. procedure writedata(const b;len:integer);
  216. procedure writeentry(ibnr:byte);
  217. procedure putdata(const b;len:integer);
  218. procedure putbyte(b:byte);
  219. procedure putword(w:word);
  220. procedure putlongint(l:longint);
  221. procedure putint64(i:int64);
  222. procedure putaint(i:aint);
  223. procedure putreal(d:ppureal);
  224. procedure putstring(s:string);
  225. procedure putnormalset(const b);
  226. procedure putsmallset(const b);
  227. procedure tempclose;
  228. function tempopen:boolean;
  229. end;
  230. implementation
  231. uses
  232. {$ifdef Test_Double_checksum}
  233. comphook,
  234. {$endif def Test_Double_checksum}
  235. crc,
  236. cutils;
  237. {*****************************************************************************
  238. Endian Handling
  239. *****************************************************************************}
  240. Function SwapLong(x : longint): longint;
  241. var
  242. y : word;
  243. z : word;
  244. Begin
  245. y := x shr 16;
  246. y := word(longint(y) shl 8) or (y shr 8);
  247. z := x and $FFFF;
  248. z := word(longint(z) shl 8) or (z shr 8);
  249. SwapLong := (longint(z) shl 16) or longint(y);
  250. End;
  251. Function SwapWord(x : word): word;
  252. var
  253. z : byte;
  254. Begin
  255. z := x shr 8;
  256. x := x and $ff;
  257. x := word(x shl 8);
  258. SwapWord := x or z;
  259. End;
  260. {*****************************************************************************
  261. TPPUFile
  262. *****************************************************************************}
  263. constructor tppufile.Create(const fn:string);
  264. begin
  265. fname:=fn;
  266. change_endian:=false;
  267. crc_only:=false;
  268. Mode:=0;
  269. NewHeader;
  270. Error:=false;
  271. closed:=true;
  272. tempclosed:=false;
  273. getmem(buf,ppubufsize);
  274. end;
  275. destructor tppufile.destroy;
  276. begin
  277. closefile;
  278. if assigned(buf) then
  279. freemem(buf,ppubufsize);
  280. end;
  281. procedure tppufile.flush;
  282. begin
  283. if Mode=2 then
  284. writebuf;
  285. end;
  286. procedure tppufile.closefile;
  287. begin
  288. {$ifdef Test_Double_checksum}
  289. if mode=2 then
  290. begin
  291. if assigned(crc_test) then
  292. dispose(crc_test);
  293. if assigned(crc_test2) then
  294. dispose(crc_test2);
  295. end;
  296. {$endif Test_Double_checksum}
  297. if Mode<>0 then
  298. begin
  299. Flush;
  300. {$I-}
  301. system.close(f);
  302. {$I+}
  303. if ioresult<>0 then;
  304. Mode:=0;
  305. closed:=true;
  306. end;
  307. end;
  308. function tppufile.CheckPPUId:boolean;
  309. begin
  310. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  311. end;
  312. function tppufile.GetPPUVersion:integer;
  313. var
  314. l : integer;
  315. code : integer;
  316. begin
  317. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  318. if code=0 then
  319. GetPPUVersion:=l
  320. else
  321. GetPPUVersion:=0;
  322. end;
  323. procedure tppufile.NewHeader;
  324. var
  325. s : string;
  326. begin
  327. fillchar(header,sizeof(tppuheader),0);
  328. str(currentppuversion,s);
  329. while length(s)<3 do
  330. s:='0'+s;
  331. with header do
  332. begin
  333. Id[1]:='P';
  334. Id[2]:='P';
  335. Id[3]:='U';
  336. Ver[1]:=s[1];
  337. Ver[2]:=s[2];
  338. Ver[3]:=s[3];
  339. end;
  340. end;
  341. {*****************************************************************************
  342. TPPUFile Reading
  343. *****************************************************************************}
  344. function tppufile.openfile:boolean;
  345. var
  346. ofmode : byte;
  347. i : integer;
  348. begin
  349. openfile:=false;
  350. assign(f,fname);
  351. ofmode:=filemode;
  352. filemode:=$0;
  353. {$I-}
  354. reset(f,1);
  355. {$I+}
  356. filemode:=ofmode;
  357. if ioresult<>0 then
  358. exit;
  359. closed:=false;
  360. {read ppuheader}
  361. fsize:=filesize(f);
  362. if fsize<sizeof(tppuheader) then
  363. exit;
  364. blockread(f,header,sizeof(tppuheader),i);
  365. { The header is always stored in little endian order }
  366. { therefore swap if on a big endian machine }
  367. {$IFDEF ENDIAN_BIG}
  368. header.compiler := SwapWord(header.compiler);
  369. header.cpu := SwapWord(header.cpu);
  370. header.target := SwapWord(header.target);
  371. header.flags := SwapLong(header.flags);
  372. header.size := SwapLong(header.size);
  373. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  374. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  375. {$ENDIF}
  376. { the PPU DATA is stored in native order }
  377. if (header.flags and uf_big_endian) = uf_big_endian then
  378. Begin
  379. {$IFDEF ENDIAN_LITTLE}
  380. change_endian := TRUE;
  381. {$ELSE}
  382. change_endian := FALSE;
  383. {$ENDIF}
  384. End
  385. else if (header.flags and uf_little_endian) = uf_little_endian then
  386. Begin
  387. {$IFDEF ENDIAN_BIG}
  388. change_endian := TRUE;
  389. {$ELSE}
  390. change_endian := FALSE;
  391. {$ENDIF}
  392. End;
  393. {reset buffer}
  394. bufstart:=i;
  395. bufsize:=0;
  396. bufidx:=0;
  397. Mode:=1;
  398. FillChar(entry,sizeof(tppuentry),0);
  399. entryidx:=0;
  400. entrystart:=0;
  401. entrybufstart:=0;
  402. Error:=false;
  403. openfile:=true;
  404. end;
  405. procedure tppufile.reloadbuf;
  406. begin
  407. inc(bufstart,bufsize);
  408. blockread(f,buf^,ppubufsize,bufsize);
  409. bufidx:=0;
  410. end;
  411. procedure tppufile.readdata(var b;len:integer);
  412. var
  413. p : pchar;
  414. left,
  415. idx : integer;
  416. begin
  417. p:=pchar(@b);
  418. idx:=0;
  419. while len>0 do
  420. begin
  421. left:=bufsize-bufidx;
  422. if len>left then
  423. begin
  424. move(buf[bufidx],p[idx],left);
  425. dec(len,left);
  426. inc(idx,left);
  427. reloadbuf;
  428. if bufsize=0 then
  429. exit;
  430. end
  431. else
  432. begin
  433. move(buf[bufidx],p[idx],len);
  434. inc(bufidx,len);
  435. exit;
  436. end;
  437. end;
  438. end;
  439. procedure tppufile.skipdata(len:integer);
  440. var
  441. left : integer;
  442. begin
  443. while len>0 do
  444. begin
  445. left:=bufsize-bufidx;
  446. if len>left then
  447. begin
  448. dec(len,left);
  449. reloadbuf;
  450. if bufsize=0 then
  451. exit;
  452. end
  453. else
  454. begin
  455. inc(bufidx,len);
  456. exit;
  457. end;
  458. end;
  459. end;
  460. function tppufile.readentry:byte;
  461. begin
  462. if entryidx<entry.size then
  463. skipdata(entry.size-entryidx);
  464. readdata(entry,sizeof(tppuentry));
  465. entrystart:=bufstart+bufidx;
  466. entryidx:=0;
  467. if not(entry.id in [mainentryid,subentryid]) then
  468. begin
  469. readentry:=iberror;
  470. error:=true;
  471. exit;
  472. end;
  473. readentry:=entry.nr;
  474. end;
  475. function tppufile.endofentry:boolean;
  476. begin
  477. endofentry:=(entryidx>=entry.size);
  478. end;
  479. function tppufile.entrysize:longint;
  480. begin
  481. entrysize:=entry.size;
  482. end;
  483. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  484. begin
  485. if entryidx+len>entry.size then
  486. res:=entry.size-entryidx
  487. else
  488. res:=len;
  489. readdata(b,res);
  490. inc(entryidx,res);
  491. end;
  492. procedure tppufile.getdata(var b;len:integer);
  493. begin
  494. if entryidx+len>entry.size then
  495. begin
  496. error:=true;
  497. exit;
  498. end;
  499. readdata(b,len);
  500. inc(entryidx,len);
  501. end;
  502. function tppufile.getbyte:byte;
  503. var
  504. b : byte;
  505. begin
  506. if entryidx+1>entry.size then
  507. begin
  508. error:=true;
  509. getbyte:=0;
  510. exit;
  511. end;
  512. readdata(b,1);
  513. getbyte:=b;
  514. inc(entryidx);
  515. end;
  516. function tppufile.getword:word;
  517. var
  518. w : word;
  519. begin
  520. if entryidx+2>entry.size then
  521. begin
  522. error:=true;
  523. getword:=0;
  524. exit;
  525. end;
  526. readdata(w,2);
  527. if change_endian then
  528. getword:=swapword(w)
  529. else
  530. getword:=w;
  531. inc(entryidx,2);
  532. end;
  533. function tppufile.getlongint:longint;
  534. var
  535. l : longint;
  536. begin
  537. if entryidx+4>entry.size then
  538. begin
  539. error:=true;
  540. getlongint:=0;
  541. exit;
  542. end;
  543. readdata(l,4);
  544. if change_endian then
  545. getlongint:=swaplong(l)
  546. else
  547. getlongint:=l;
  548. inc(entryidx,4);
  549. end;
  550. function tppufile.getint64:int64;
  551. var
  552. i : int64;
  553. begin
  554. if entryidx+8>entry.size then
  555. begin
  556. error:=true;
  557. result:=0;
  558. exit;
  559. end;
  560. readdata(i,8);
  561. if change_endian then
  562. result:=swapint64(i)
  563. else
  564. result:=i;
  565. inc(entryidx,8);
  566. end;
  567. function tppufile.getaint:aint;
  568. begin
  569. {$ifdef cpu64bit}
  570. result:=getint64;
  571. {$else cpu64bit}
  572. result:=getlongint;
  573. {$endif cpu64bit}
  574. end;
  575. function tppufile.getreal:ppureal;
  576. var
  577. d : ppureal;
  578. begin
  579. if entryidx+sizeof(ppureal)>entry.size then
  580. begin
  581. error:=true;
  582. getreal:=0;
  583. exit;
  584. end;
  585. readdata(d,sizeof(ppureal));
  586. getreal:=d;
  587. inc(entryidx,sizeof(ppureal));
  588. end;
  589. function tppufile.getstring:string;
  590. var
  591. s : string;
  592. begin
  593. s[0]:=chr(getbyte);
  594. if entryidx+length(s)>entry.size then
  595. begin
  596. error:=true;
  597. exit;
  598. end;
  599. ReadData(s[1],length(s));
  600. getstring:=s;
  601. inc(entryidx,length(s));
  602. end;
  603. procedure tppufile.getsmallset(var b);
  604. var
  605. l : longint;
  606. begin
  607. l:=getlongint;
  608. longint(b):=l;
  609. end;
  610. procedure tppufile.getnormalset(var b);
  611. type
  612. SetLongintArray = Array [0..7] of longint;
  613. var
  614. i : longint;
  615. begin
  616. if change_endian then
  617. begin
  618. for i:=0 to 7 do
  619. SetLongintArray(b)[i]:=getlongint;
  620. end
  621. else
  622. getdata(b,32);
  623. end;
  624. function tppufile.skipuntilentry(untilb:byte):boolean;
  625. var
  626. b : byte;
  627. begin
  628. repeat
  629. b:=readentry;
  630. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  631. skipuntilentry:=(b=untilb);
  632. end;
  633. {*****************************************************************************
  634. TPPUFile Writing
  635. *****************************************************************************}
  636. function tppufile.createfile:boolean;
  637. begin
  638. createfile:=false;
  639. {$ifdef INTFPPU}
  640. if crc_only then
  641. begin
  642. fname:=fname+'.intf';
  643. crc_only:=false;
  644. end;
  645. {$endif}
  646. if not crc_only then
  647. begin
  648. assign(f,fname);
  649. {$I-}
  650. rewrite(f,1);
  651. {$I+}
  652. if ioresult<>0 then
  653. exit;
  654. Mode:=2;
  655. {write header for sure}
  656. blockwrite(f,header,sizeof(tppuheader));
  657. end;
  658. bufsize:=ppubufsize;
  659. bufstart:=sizeof(tppuheader);
  660. bufidx:=0;
  661. {reset}
  662. crc:=cardinal($ffffffff);
  663. interface_crc:=cardinal($ffffffff);
  664. do_interface_crc:=true;
  665. Error:=false;
  666. do_crc:=true;
  667. size:=0;
  668. entrytyp:=mainentryid;
  669. {start}
  670. NewEntry;
  671. createfile:=true;
  672. end;
  673. procedure tppufile.writeheader;
  674. var
  675. opos : integer;
  676. begin
  677. if crc_only then
  678. exit;
  679. { flush buffer }
  680. writebuf;
  681. { update size (w/o header!) in the header }
  682. header.size:=bufstart-sizeof(tppuheader);
  683. { set the endian flag }
  684. {$ifndef FPC_BIG_ENDIAN}
  685. header.flags := header.flags or uf_little_endian;
  686. {$else not FPC_BIG_ENDIAN}
  687. header.flags := header.flags or uf_big_endian;
  688. { Now swap the header in the correct endian (always little endian) }
  689. header.compiler := SwapWord(header.compiler);
  690. header.cpu := SwapWord(header.cpu);
  691. header.target := SwapWord(header.target);
  692. header.flags := SwapLong(header.flags);
  693. header.size := SwapLong(header.size);
  694. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  695. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  696. {$endif not FPC_BIG_ENDIAN}
  697. { write header and restore filepos after it }
  698. opos:=filepos(f);
  699. seek(f,0);
  700. blockwrite(f,header,sizeof(tppuheader));
  701. seek(f,opos);
  702. end;
  703. procedure tppufile.writebuf;
  704. begin
  705. if not crc_only then
  706. blockwrite(f,buf^,bufidx);
  707. inc(bufstart,bufidx);
  708. bufidx:=0;
  709. end;
  710. procedure tppufile.writedata(const b;len:integer);
  711. var
  712. p : pchar;
  713. left,
  714. idx : integer;
  715. begin
  716. if crc_only then
  717. exit;
  718. p:=pchar(@b);
  719. idx:=0;
  720. while len>0 do
  721. begin
  722. left:=bufsize-bufidx;
  723. if len>left then
  724. begin
  725. move(p[idx],buf[bufidx],left);
  726. dec(len,left);
  727. inc(idx,left);
  728. inc(bufidx,left);
  729. writebuf;
  730. end
  731. else
  732. begin
  733. move(p[idx],buf[bufidx],len);
  734. inc(bufidx,len);
  735. exit;
  736. end;
  737. end;
  738. end;
  739. procedure tppufile.NewEntry;
  740. begin
  741. with entry do
  742. begin
  743. id:=entrytyp;
  744. nr:=ibend;
  745. size:=0;
  746. end;
  747. {Reset Entry State}
  748. entryidx:=0;
  749. entrybufstart:=bufstart;
  750. entrystart:=bufstart+bufidx;
  751. {Alloc in buffer}
  752. writedata(entry,sizeof(tppuentry));
  753. end;
  754. procedure tppufile.writeentry(ibnr:byte);
  755. var
  756. opos : integer;
  757. begin
  758. {create entry}
  759. entry.id:=entrytyp;
  760. entry.nr:=ibnr;
  761. entry.size:=entryidx;
  762. {it's already been sent to disk ?}
  763. if entrybufstart<>bufstart then
  764. begin
  765. if not crc_only then
  766. begin
  767. {flush to be sure}
  768. WriteBuf;
  769. {write entry}
  770. opos:=filepos(f);
  771. seek(f,entrystart);
  772. blockwrite(f,entry,sizeof(tppuentry));
  773. seek(f,opos);
  774. end;
  775. entrybufstart:=bufstart;
  776. end
  777. else
  778. move(entry,buf[entrystart-bufstart],sizeof(entry));
  779. {Add New Entry, which is ibend by default}
  780. entrystart:=bufstart+bufidx; {next entry position}
  781. NewEntry;
  782. end;
  783. procedure tppufile.putdata(const b;len:integer);
  784. begin
  785. if do_crc then
  786. begin
  787. crc:=UpdateCrc32(crc,b,len);
  788. {$ifdef Test_Double_checksum}
  789. if crc_only then
  790. begin
  791. crc_test2^[crc_index2]:=crc;
  792. {$ifdef Test_Double_checksum_write}
  793. Writeln(CRCFile,crc);
  794. {$endif Test_Double_checksum_write}
  795. if crc_index2<crc_array_size then
  796. inc(crc_index2);
  797. end
  798. else
  799. begin
  800. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  801. (crc_test2^[crcindex2]<>crc) then
  802. Do_comment(V_Note,'impl CRC changed');
  803. {$ifdef Test_Double_checksum_write}
  804. Writeln(CRCFile,crc);
  805. {$endif Test_Double_checksum_write}
  806. inc(crcindex2);
  807. end;
  808. {$endif def Test_Double_checksum}
  809. if do_interface_crc then
  810. begin
  811. interface_crc:=UpdateCrc32(interface_crc,b,len);
  812. {$ifdef Test_Double_checksum}
  813. if crc_only then
  814. begin
  815. crc_test^[crc_index]:=interface_crc;
  816. {$ifdef Test_Double_checksum_write}
  817. Writeln(CRCFile,interface_crc);
  818. {$endif Test_Double_checksum_write}
  819. if crc_index<crc_array_size then
  820. inc(crc_index);
  821. end
  822. else
  823. begin
  824. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  825. (crc_test^[crcindex]<>interface_crc) then
  826. Do_comment(V_Warning,'CRC changed');
  827. {$ifdef Test_Double_checksum_write}
  828. Writeln(CRCFile,interface_crc);
  829. {$endif Test_Double_checksum_write}
  830. inc(crcindex);
  831. end;
  832. {$endif def Test_Double_checksum}
  833. end;
  834. end;
  835. if not crc_only then
  836. writedata(b,len);
  837. inc(entryidx,len);
  838. end;
  839. procedure tppufile.putbyte(b:byte);
  840. begin
  841. putdata(b,1);
  842. end;
  843. procedure tppufile.putword(w:word);
  844. begin
  845. putdata(w,2);
  846. end;
  847. procedure tppufile.putlongint(l:longint);
  848. begin
  849. putdata(l,4);
  850. end;
  851. procedure tppufile.putint64(i:int64);
  852. begin
  853. putdata(i,8);
  854. end;
  855. procedure tppufile.putaint(i:aint);
  856. begin
  857. putdata(i,sizeof(aint));
  858. end;
  859. procedure tppufile.putreal(d:ppureal);
  860. begin
  861. putdata(d,sizeof(ppureal));
  862. end;
  863. procedure tppufile.putstring(s:string);
  864. begin
  865. putdata(s,length(s)+1);
  866. end;
  867. procedure tppufile.putsmallset(const b);
  868. var
  869. l : longint;
  870. begin
  871. l:=longint(b);
  872. putlongint(l);
  873. end;
  874. procedure tppufile.putnormalset(const b);
  875. type
  876. SetLongintArray = Array [0..7] of longint;
  877. var
  878. i : longint;
  879. tempb : setlongintarray;
  880. begin
  881. if change_endian then
  882. begin
  883. for i:=0 to 7 do
  884. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  885. putdata(tempb,32);
  886. end
  887. else
  888. putdata(b,32);
  889. end;
  890. procedure tppufile.tempclose;
  891. begin
  892. if not closed then
  893. begin
  894. closepos:=filepos(f);
  895. {$I-}
  896. system.close(f);
  897. {$I+}
  898. if ioresult<>0 then;
  899. closed:=true;
  900. tempclosed:=true;
  901. end;
  902. end;
  903. function tppufile.tempopen:boolean;
  904. var
  905. ofm : byte;
  906. begin
  907. tempopen:=false;
  908. if not closed or not tempclosed then
  909. exit;
  910. ofm:=filemode;
  911. filemode:=0;
  912. {$I-}
  913. reset(f,1);
  914. {$I+}
  915. filemode:=ofm;
  916. if ioresult<>0 then
  917. exit;
  918. closed:=false;
  919. tempclosed:=false;
  920. { restore state }
  921. seek(f,closepos);
  922. tempopen:=true;
  923. end;
  924. end.
  925. {
  926. $Log$
  927. Revision 1.47 2004-03-23 22:34:49 peter
  928. * constants ordinals now always have a type assigned
  929. * integer constants have the smallest type, unsigned prefered over
  930. signed
  931. Revision 1.46 2004/02/27 10:21:05 florian
  932. * top_symbol killed
  933. + refaddr to treference added
  934. + refsymbol to treference added
  935. * top_local stuff moved to an extra record to save memory
  936. + aint introduced
  937. * tppufile.get/putint64/aint implemented
  938. Revision 1.45 2004/01/30 13:42:03 florian
  939. * fixed more alignment issues
  940. Revision 1.44 2003/11/10 22:02:52 peter
  941. * cross unit inlining fixed
  942. Revision 1.43 2003/10/22 20:40:00 peter
  943. * write derefdata in a separate ppu entry
  944. Revision 1.42 2003/09/23 17:56:05 peter
  945. * locals and paras are allocated in the code generation
  946. * tvarsym.localloc contains the location of para/local when
  947. generating code for the current procedure
  948. Revision 1.41 2003/07/05 20:06:28 jonas
  949. * fixed some range check errors that occurred on big endian systems
  950. * slightly optimized the swap*() functions
  951. Revision 1.40 2003/06/17 16:34:44 jonas
  952. * lots of newra fixes (need getfuncretparaloc implementation for i386)!
  953. * renamed all_intregisters to volatile_intregisters and made it
  954. processor dependent
  955. Revision 1.39 2003/06/07 20:26:32 peter
  956. * re-resolving added instead of reloading from ppu
  957. * tderef object added to store deref info for resolving
  958. Revision 1.38 2003/05/26 19:39:51 peter
  959. * removed systems unit
  960. Revision 1.37 2003/05/26 15:49:54 jonas
  961. * endian fix is now done using a define instead of with source_info
  962. Revision 1.36 2003/05/24 13:37:10 jonas
  963. * endian fixes
  964. Revision 1.35 2003/05/23 17:03:51 peter
  965. * write header for crc_only
  966. Revision 1.34 2003/04/25 20:59:34 peter
  967. * removed funcretn,funcretsym, function result is now in varsym
  968. and aliases for result and function name are added using absolutesym
  969. * vs_hidden parameter for funcret passed in parameter
  970. * vs_hidden fixes
  971. * writenode changed to printnode and released from extdebug
  972. * -vp option added to generate a tree.log with the nodetree
  973. * nicer printnode for statements, callnode
  974. Revision 1.33 2003/04/24 13:03:01 florian
  975. * comp is now written with its bit pattern to the ppu instead as an extended
  976. Revision 1.32 2003/04/23 14:42:07 daniel
  977. * Further register allocator work. Compiler now smaller with new
  978. allocator than without.
  979. * Somebody forgot to adjust ppu version number
  980. Revision 1.31 2003/04/10 17:57:53 peter
  981. * vs_hidden released
  982. Revision 1.30 2003/03/17 15:54:22 peter
  983. * store symoptions also for procdef
  984. * check symoptions (private,public) when calculating possible
  985. overload candidates
  986. Revision 1.29 2003/01/08 18:43:56 daniel
  987. * Tregister changed into a record
  988. Revision 1.28 2002/11/15 01:58:53 peter
  989. * merged changes from 1.0.7 up to 04-11
  990. - -V option for generating bug report tracing
  991. - more tracing for option parsing
  992. - errors for cdecl and high()
  993. - win32 import stabs
  994. - win32 records<=8 are returned in eax:edx (turned off by default)
  995. - heaptrc update
  996. - more info for temp management in .s file with EXTDEBUG
  997. Revision 1.27 2002/10/14 19:42:33 peter
  998. * only use init tables for threadvars
  999. Revision 1.26 2002/08/18 20:06:25 peter
  1000. * inlining is now also allowed in interface
  1001. * renamed write/load to ppuwrite/ppuload
  1002. * tnode storing in ppu
  1003. * nld,ncon,nbas are already updated for storing in ppu
  1004. Revision 1.25 2002/08/15 19:10:35 peter
  1005. * first things tai,tnode storing in ppu
  1006. Revision 1.24 2002/08/15 15:09:42 carl
  1007. + fpu emulation helpers (ppu checking also)
  1008. Revision 1.23 2002/08/13 21:40:56 florian
  1009. * more fixes for ppc calling conventions
  1010. Revision 1.22 2002/08/11 13:24:12 peter
  1011. * saving of asmsymbols in ppu supported
  1012. * asmsymbollist global is removed and moved into a new class
  1013. tasmlibrarydata that will hold the info of a .a file which
  1014. corresponds with a single module. Added librarydata to tmodule
  1015. to keep the library info stored for the module. In the future the
  1016. objectfiles will also be stored to the tasmlibrarydata class
  1017. * all getlabel/newasmsymbol and friends are moved to the new class
  1018. Revision 1.21 2002/08/09 07:33:02 florian
  1019. * a couple of interface related fixes
  1020. Revision 1.20 2002/05/18 13:34:13 peter
  1021. * readded missing revisions
  1022. Revision 1.19 2002/05/16 19:46:44 carl
  1023. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  1024. + try to fix temp allocation (still in ifdef)
  1025. + generic constructor calls
  1026. + start of tassembler / tmodulebase class cleanup
  1027. Revision 1.17 2002/04/04 19:06:03 peter
  1028. * removed unused units
  1029. * use tlocation.size in cg.a_*loc*() routines
  1030. Revision 1.16 2002/03/31 20:26:36 jonas
  1031. + a_loadfpu_* and a_loadmm_* methods in tcg
  1032. * register allocation is now handled by a class and is mostly processor
  1033. independent (+rgobj.pas and i386/rgcpu.pas)
  1034. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  1035. * some small improvements and fixes to the optimizer
  1036. * some register allocation fixes
  1037. * some fpuvaroffset fixes in the unary minus node
  1038. * push/popusedregisters is now called rg.save/restoreusedregisters and
  1039. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  1040. also better optimizable)
  1041. * fixed and optimized register saving/restoring for new/dispose nodes
  1042. * LOC_FPU locations now also require their "register" field to be set to
  1043. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  1044. - list field removed of the tnode class because it's not used currently
  1045. and can cause hard-to-find bugs
  1046. Revision 1.15 2002/03/28 16:07:52 armin
  1047. + initialize threadvars defined local in units
  1048. }