ppu.pas 24 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106
  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. globtype;
  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. {$ifdef ansistring_bits}
  37. CurrentPPUVersion=44;
  38. {$else}
  39. CurrentPPUVersion=44;
  40. {$endif}
  41. { buffer sizes }
  42. maxentrysize = 1024;
  43. ppubufsize = 16384;
  44. {ppu entries}
  45. mainentryid = 1;
  46. subentryid = 2;
  47. {special}
  48. iberror = 0;
  49. ibstartdefs = 248;
  50. ibenddefs = 249;
  51. ibstartsyms = 250;
  52. ibendsyms = 251;
  53. ibendinterface = 252;
  54. ibendimplementation = 253;
  55. ibendbrowser = 254;
  56. ibend = 255;
  57. {general}
  58. ibmodulename = 1;
  59. ibsourcefiles = 2;
  60. ibloadunit = 3;
  61. ibinitunit = 4;
  62. iblinkunitofiles = 5;
  63. iblinkunitstaticlibs = 6;
  64. iblinkunitsharedlibs = 7;
  65. iblinkotherofiles = 8;
  66. iblinkotherstaticlibs = 9;
  67. iblinkothersharedlibs = 10;
  68. ibdbxcount = 11;
  69. ibsymref = 12;
  70. ibdefref = 13;
  71. ibendsymtablebrowser = 14;
  72. ibbeginsymtablebrowser = 15;
  73. ibusedmacros = 16;
  74. ibderefdata = 17;
  75. {syms}
  76. ibtypesym = 20;
  77. ibprocsym = 21;
  78. ibvarsym = 22;
  79. ibconstsym = 23;
  80. ibenumsym = 24;
  81. ibtypedconstsym = 25;
  82. ibabsolutesym = 26;
  83. ibpropertysym = 27;
  84. ibvarsym_C = 28;
  85. ibunitsym = 29; { needed for browser }
  86. iblabelsym = 30;
  87. ibsyssym = 31;
  88. ibrttisym = 32;
  89. {definitions}
  90. iborddef = 40;
  91. ibpointerdef = 41;
  92. ibarraydef = 42;
  93. ibprocdef = 43;
  94. ibshortstringdef = 44;
  95. ibrecorddef = 45;
  96. ibfiledef = 46;
  97. ibformaldef = 47;
  98. ibobjectdef = 48;
  99. ibenumdef = 49;
  100. ibsetdef = 50;
  101. ibprocvardef = 51;
  102. ibfloatdef = 52;
  103. ibclassrefdef = 53;
  104. iblongstringdef = 54;
  105. {$ifdef ansistring_bits}
  106. ibansistring16def = 58;
  107. ibansistring32def = 55;
  108. ibansistring64def = 59;
  109. {$else}
  110. ibansistringdef = 55;
  111. {$endif}
  112. ibwidestringdef = 56;
  113. ibvariantdef = 57;
  114. {implementation/objectdata}
  115. ibnodetree = 80;
  116. ibasmsymbols = 81;
  117. { unit flags }
  118. uf_init = $1;
  119. uf_finalize = $2;
  120. uf_big_endian = $4;
  121. uf_has_dbx = $8;
  122. uf_has_browser = $10;
  123. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  124. uf_smart_linked = $40; { the ppu can be smartlinked }
  125. uf_static_linked = $80; { the ppu can be linked static }
  126. uf_shared_linked = $100; { the ppu can be linked shared }
  127. uf_local_browser = $200;
  128. uf_no_link = $400; { unit has no .o generated, but can still have
  129. external linking! }
  130. uf_has_resources = $800; { unit has resource section }
  131. uf_little_endian = $1000;
  132. uf_release = $2000; { unit was compiled with -Ur option }
  133. uf_threadvars = $4000; { unit has threadvars }
  134. uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
  135. uf_has_debuginfo = $10000; { this unit has debuginfo generated }
  136. uf_local_symtable = $20000; { this unit has a local symtable stored }
  137. type
  138. ppureal=extended;
  139. tppuerror=(ppuentrytoobig,ppuentryerror);
  140. tppuheader=record
  141. id : array[1..3] of char; { = 'PPU' }
  142. ver : array[1..3] of char;
  143. compiler : word;
  144. cpu : word;
  145. target : word;
  146. flags : longint;
  147. size : longint; { size of the ppufile without header }
  148. checksum : cardinal; { checksum for this ppufile }
  149. interface_checksum : cardinal;
  150. future : array[0..2] of longint;
  151. end;
  152. tppuentry=packed record
  153. size : longint;
  154. id : byte;
  155. nr : byte;
  156. end;
  157. tppufile=class
  158. private
  159. f : file;
  160. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  161. fname : string;
  162. fsize : integer;
  163. {$ifdef Test_Double_checksum}
  164. public
  165. crcindex,
  166. crc_index,
  167. crcindex2,
  168. crc_index2 : cardinal;
  169. crc_test,
  170. crc_test2 : pcrc_array;
  171. private
  172. {$endif def Test_Double_checksum}
  173. change_endian : boolean;
  174. buf : pchar;
  175. bufstart,
  176. bufsize,
  177. bufidx : integer;
  178. entrybufstart,
  179. entrystart,
  180. entryidx : integer;
  181. entry : tppuentry;
  182. closed,
  183. tempclosed : boolean;
  184. closepos : integer;
  185. public
  186. entrytyp : byte;
  187. header : tppuheader;
  188. size : integer;
  189. crc,
  190. interface_crc : cardinal;
  191. error,
  192. do_crc,
  193. do_interface_crc : boolean;
  194. crc_only : boolean; { used to calculate interface_crc before implementation }
  195. constructor Create(const fn:string);
  196. destructor Destroy;override;
  197. procedure flush;
  198. procedure closefile;
  199. function CheckPPUId:boolean;
  200. function GetPPUVersion:integer;
  201. procedure NewHeader;
  202. procedure NewEntry;
  203. {read}
  204. function openfile:boolean;
  205. procedure reloadbuf;
  206. procedure readdata(var b;len:integer);
  207. procedure skipdata(len:integer);
  208. function readentry:byte;
  209. function EndOfEntry:boolean;
  210. function entrysize:longint;
  211. procedure getdatabuf(var b;len:integer;var res:integer);
  212. procedure getdata(var b;len:integer);
  213. function getbyte:byte;
  214. function getword:word;
  215. function getlongint:longint;
  216. function getint64:int64;
  217. function getaint:aint;
  218. function getreal:ppureal;
  219. function getstring:string;
  220. procedure getnormalset(var b);
  221. procedure getsmallset(var b);
  222. function skipuntilentry(untilb:byte):boolean;
  223. {write}
  224. function createfile:boolean;
  225. procedure writeheader;
  226. procedure writebuf;
  227. procedure writedata(const b;len:integer);
  228. procedure writeentry(ibnr:byte);
  229. procedure putdata(const b;len:integer);
  230. procedure putbyte(b:byte);
  231. procedure putword(w:word);
  232. procedure putlongint(l:longint);
  233. procedure putint64(i:int64);
  234. procedure putaint(i:aint);
  235. procedure putreal(d:ppureal);
  236. procedure putstring(s:string);
  237. procedure putnormalset(const b);
  238. procedure putsmallset(const b);
  239. procedure tempclose;
  240. function tempopen:boolean;
  241. end;
  242. implementation
  243. uses
  244. {$ifdef Test_Double_checksum}
  245. comphook,
  246. {$endif def Test_Double_checksum}
  247. crc,
  248. cutils;
  249. {*****************************************************************************
  250. Endian Handling
  251. *****************************************************************************}
  252. Function SwapLong(x : longint): longint;
  253. var
  254. y : word;
  255. z : word;
  256. Begin
  257. y := x shr 16;
  258. y := word(longint(y) shl 8) or (y shr 8);
  259. z := x and $FFFF;
  260. z := word(longint(z) shl 8) or (z shr 8);
  261. SwapLong := (longint(z) shl 16) or longint(y);
  262. End;
  263. Function SwapWord(x : word): word;
  264. var
  265. z : byte;
  266. Begin
  267. z := x shr 8;
  268. x := x and $ff;
  269. x := word(x shl 8);
  270. SwapWord := x or z;
  271. End;
  272. {*****************************************************************************
  273. TPPUFile
  274. *****************************************************************************}
  275. constructor tppufile.Create(const fn:string);
  276. begin
  277. fname:=fn;
  278. change_endian:=false;
  279. crc_only:=false;
  280. Mode:=0;
  281. NewHeader;
  282. Error:=false;
  283. closed:=true;
  284. tempclosed:=false;
  285. getmem(buf,ppubufsize);
  286. end;
  287. destructor tppufile.destroy;
  288. begin
  289. closefile;
  290. if assigned(buf) then
  291. freemem(buf,ppubufsize);
  292. end;
  293. procedure tppufile.flush;
  294. begin
  295. if Mode=2 then
  296. writebuf;
  297. end;
  298. procedure tppufile.closefile;
  299. begin
  300. {$ifdef Test_Double_checksum}
  301. if mode=2 then
  302. begin
  303. if assigned(crc_test) then
  304. dispose(crc_test);
  305. if assigned(crc_test2) then
  306. dispose(crc_test2);
  307. end;
  308. {$endif Test_Double_checksum}
  309. if Mode<>0 then
  310. begin
  311. Flush;
  312. {$I-}
  313. system.close(f);
  314. {$I+}
  315. if ioresult<>0 then;
  316. Mode:=0;
  317. closed:=true;
  318. end;
  319. end;
  320. function tppufile.CheckPPUId:boolean;
  321. begin
  322. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  323. end;
  324. function tppufile.GetPPUVersion:integer;
  325. var
  326. l : integer;
  327. code : integer;
  328. begin
  329. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  330. if code=0 then
  331. GetPPUVersion:=l
  332. else
  333. GetPPUVersion:=0;
  334. end;
  335. procedure tppufile.NewHeader;
  336. var
  337. s : string;
  338. begin
  339. fillchar(header,sizeof(tppuheader),0);
  340. str(currentppuversion,s);
  341. while length(s)<3 do
  342. s:='0'+s;
  343. with header do
  344. begin
  345. Id[1]:='P';
  346. Id[2]:='P';
  347. Id[3]:='U';
  348. Ver[1]:=s[1];
  349. Ver[2]:=s[2];
  350. Ver[3]:=s[3];
  351. end;
  352. end;
  353. {*****************************************************************************
  354. TPPUFile Reading
  355. *****************************************************************************}
  356. function tppufile.openfile:boolean;
  357. var
  358. ofmode : byte;
  359. i : integer;
  360. begin
  361. openfile:=false;
  362. assign(f,fname);
  363. ofmode:=filemode;
  364. filemode:=$0;
  365. {$I-}
  366. reset(f,1);
  367. {$I+}
  368. filemode:=ofmode;
  369. if ioresult<>0 then
  370. exit;
  371. closed:=false;
  372. {read ppuheader}
  373. fsize:=filesize(f);
  374. if fsize<sizeof(tppuheader) then
  375. exit;
  376. blockread(f,header,sizeof(tppuheader),i);
  377. { The header is always stored in little endian order }
  378. { therefore swap if on a big endian machine }
  379. {$IFDEF ENDIAN_BIG}
  380. header.compiler := SwapWord(header.compiler);
  381. header.cpu := SwapWord(header.cpu);
  382. header.target := SwapWord(header.target);
  383. header.flags := SwapLong(header.flags);
  384. header.size := SwapLong(header.size);
  385. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  386. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  387. {$ENDIF}
  388. { the PPU DATA is stored in native order }
  389. if (header.flags and uf_big_endian) = uf_big_endian then
  390. Begin
  391. {$IFDEF ENDIAN_LITTLE}
  392. change_endian := TRUE;
  393. {$ELSE}
  394. change_endian := FALSE;
  395. {$ENDIF}
  396. End
  397. else if (header.flags and uf_little_endian) = uf_little_endian then
  398. Begin
  399. {$IFDEF ENDIAN_BIG}
  400. change_endian := TRUE;
  401. {$ELSE}
  402. change_endian := FALSE;
  403. {$ENDIF}
  404. End;
  405. {reset buffer}
  406. bufstart:=i;
  407. bufsize:=0;
  408. bufidx:=0;
  409. Mode:=1;
  410. FillChar(entry,sizeof(tppuentry),0);
  411. entryidx:=0;
  412. entrystart:=0;
  413. entrybufstart:=0;
  414. Error:=false;
  415. openfile:=true;
  416. end;
  417. procedure tppufile.reloadbuf;
  418. begin
  419. inc(bufstart,bufsize);
  420. blockread(f,buf^,ppubufsize,bufsize);
  421. bufidx:=0;
  422. end;
  423. procedure tppufile.readdata(var b;len:integer);
  424. var
  425. p : pchar;
  426. left,
  427. idx : integer;
  428. begin
  429. p:=pchar(@b);
  430. idx:=0;
  431. while len>0 do
  432. begin
  433. left:=bufsize-bufidx;
  434. if len>left then
  435. begin
  436. move(buf[bufidx],p[idx],left);
  437. dec(len,left);
  438. inc(idx,left);
  439. reloadbuf;
  440. if bufsize=0 then
  441. exit;
  442. end
  443. else
  444. begin
  445. move(buf[bufidx],p[idx],len);
  446. inc(bufidx,len);
  447. exit;
  448. end;
  449. end;
  450. end;
  451. procedure tppufile.skipdata(len:integer);
  452. var
  453. left : integer;
  454. begin
  455. while len>0 do
  456. begin
  457. left:=bufsize-bufidx;
  458. if len>left then
  459. begin
  460. dec(len,left);
  461. reloadbuf;
  462. if bufsize=0 then
  463. exit;
  464. end
  465. else
  466. begin
  467. inc(bufidx,len);
  468. exit;
  469. end;
  470. end;
  471. end;
  472. function tppufile.readentry:byte;
  473. begin
  474. if entryidx<entry.size then
  475. skipdata(entry.size-entryidx);
  476. readdata(entry,sizeof(tppuentry));
  477. entrystart:=bufstart+bufidx;
  478. entryidx:=0;
  479. if not(entry.id in [mainentryid,subentryid]) then
  480. begin
  481. readentry:=iberror;
  482. error:=true;
  483. exit;
  484. end;
  485. readentry:=entry.nr;
  486. end;
  487. function tppufile.endofentry:boolean;
  488. begin
  489. endofentry:=(entryidx>=entry.size);
  490. end;
  491. function tppufile.entrysize:longint;
  492. begin
  493. entrysize:=entry.size;
  494. end;
  495. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  496. begin
  497. if entryidx+len>entry.size then
  498. res:=entry.size-entryidx
  499. else
  500. res:=len;
  501. readdata(b,res);
  502. inc(entryidx,res);
  503. end;
  504. procedure tppufile.getdata(var b;len:integer);
  505. begin
  506. if entryidx+len>entry.size then
  507. begin
  508. error:=true;
  509. exit;
  510. end;
  511. readdata(b,len);
  512. inc(entryidx,len);
  513. end;
  514. function tppufile.getbyte:byte;
  515. var
  516. b : byte;
  517. begin
  518. if entryidx+1>entry.size then
  519. begin
  520. error:=true;
  521. getbyte:=0;
  522. exit;
  523. end;
  524. readdata(b,1);
  525. getbyte:=b;
  526. inc(entryidx);
  527. end;
  528. function tppufile.getword:word;
  529. var
  530. w : word;
  531. begin
  532. if entryidx+2>entry.size then
  533. begin
  534. error:=true;
  535. getword:=0;
  536. exit;
  537. end;
  538. readdata(w,2);
  539. if change_endian then
  540. getword:=swapword(w)
  541. else
  542. getword:=w;
  543. inc(entryidx,2);
  544. end;
  545. function tppufile.getlongint:longint;
  546. var
  547. l : longint;
  548. begin
  549. if entryidx+4>entry.size then
  550. begin
  551. error:=true;
  552. getlongint:=0;
  553. exit;
  554. end;
  555. readdata(l,4);
  556. if change_endian then
  557. getlongint:=swaplong(l)
  558. else
  559. getlongint:=l;
  560. inc(entryidx,4);
  561. end;
  562. function tppufile.getint64:int64;
  563. var
  564. i : int64;
  565. begin
  566. if entryidx+8>entry.size then
  567. begin
  568. error:=true;
  569. result:=0;
  570. exit;
  571. end;
  572. readdata(i,8);
  573. if change_endian then
  574. result:=swapint64(i)
  575. else
  576. result:=i;
  577. inc(entryidx,8);
  578. end;
  579. function tppufile.getaint:aint;
  580. begin
  581. {$ifdef cpu64bit}
  582. result:=getint64;
  583. {$else cpu64bit}
  584. result:=getlongint;
  585. {$endif cpu64bit}
  586. end;
  587. function tppufile.getreal:ppureal;
  588. var
  589. d : ppureal;
  590. begin
  591. if entryidx+sizeof(ppureal)>entry.size then
  592. begin
  593. error:=true;
  594. getreal:=0;
  595. exit;
  596. end;
  597. readdata(d,sizeof(ppureal));
  598. getreal:=d;
  599. inc(entryidx,sizeof(ppureal));
  600. end;
  601. function tppufile.getstring:string;
  602. var
  603. s : string;
  604. begin
  605. s[0]:=chr(getbyte);
  606. if entryidx+length(s)>entry.size then
  607. begin
  608. error:=true;
  609. exit;
  610. end;
  611. ReadData(s[1],length(s));
  612. getstring:=s;
  613. inc(entryidx,length(s));
  614. end;
  615. procedure tppufile.getsmallset(var b);
  616. var
  617. l : longint;
  618. begin
  619. l:=getlongint;
  620. longint(b):=l;
  621. end;
  622. procedure tppufile.getnormalset(var b);
  623. type
  624. SetLongintArray = Array [0..7] of longint;
  625. var
  626. i : longint;
  627. begin
  628. if change_endian then
  629. begin
  630. for i:=0 to 7 do
  631. SetLongintArray(b)[i]:=getlongint;
  632. end
  633. else
  634. getdata(b,32);
  635. end;
  636. function tppufile.skipuntilentry(untilb:byte):boolean;
  637. var
  638. b : byte;
  639. begin
  640. repeat
  641. b:=readentry;
  642. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  643. skipuntilentry:=(b=untilb);
  644. end;
  645. {*****************************************************************************
  646. TPPUFile Writing
  647. *****************************************************************************}
  648. function tppufile.createfile:boolean;
  649. begin
  650. createfile:=false;
  651. {$ifdef INTFPPU}
  652. if crc_only then
  653. begin
  654. fname:=fname+'.intf';
  655. crc_only:=false;
  656. end;
  657. {$endif}
  658. if not crc_only then
  659. begin
  660. assign(f,fname);
  661. {$I-}
  662. rewrite(f,1);
  663. {$I+}
  664. if ioresult<>0 then
  665. exit;
  666. Mode:=2;
  667. {write header for sure}
  668. blockwrite(f,header,sizeof(tppuheader));
  669. end;
  670. bufsize:=ppubufsize;
  671. bufstart:=sizeof(tppuheader);
  672. bufidx:=0;
  673. {reset}
  674. crc:=cardinal($ffffffff);
  675. interface_crc:=cardinal($ffffffff);
  676. do_interface_crc:=true;
  677. Error:=false;
  678. do_crc:=true;
  679. size:=0;
  680. entrytyp:=mainentryid;
  681. {start}
  682. NewEntry;
  683. createfile:=true;
  684. end;
  685. procedure tppufile.writeheader;
  686. var
  687. opos : integer;
  688. begin
  689. if crc_only then
  690. exit;
  691. { flush buffer }
  692. writebuf;
  693. { update size (w/o header!) in the header }
  694. header.size:=bufstart-sizeof(tppuheader);
  695. { set the endian flag }
  696. {$ifndef FPC_BIG_ENDIAN}
  697. header.flags := header.flags or uf_little_endian;
  698. {$else not FPC_BIG_ENDIAN}
  699. header.flags := header.flags or uf_big_endian;
  700. { Now swap the header in the correct endian (always little endian) }
  701. header.compiler := SwapWord(header.compiler);
  702. header.cpu := SwapWord(header.cpu);
  703. header.target := SwapWord(header.target);
  704. header.flags := SwapLong(header.flags);
  705. header.size := SwapLong(header.size);
  706. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  707. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  708. {$endif not FPC_BIG_ENDIAN}
  709. { write header and restore filepos after it }
  710. opos:=filepos(f);
  711. seek(f,0);
  712. blockwrite(f,header,sizeof(tppuheader));
  713. seek(f,opos);
  714. end;
  715. procedure tppufile.writebuf;
  716. begin
  717. if not crc_only then
  718. blockwrite(f,buf^,bufidx);
  719. inc(bufstart,bufidx);
  720. bufidx:=0;
  721. end;
  722. procedure tppufile.writedata(const b;len:integer);
  723. var
  724. p : pchar;
  725. left,
  726. idx : integer;
  727. begin
  728. if crc_only then
  729. exit;
  730. p:=pchar(@b);
  731. idx:=0;
  732. while len>0 do
  733. begin
  734. left:=bufsize-bufidx;
  735. if len>left then
  736. begin
  737. move(p[idx],buf[bufidx],left);
  738. dec(len,left);
  739. inc(idx,left);
  740. inc(bufidx,left);
  741. writebuf;
  742. end
  743. else
  744. begin
  745. move(p[idx],buf[bufidx],len);
  746. inc(bufidx,len);
  747. exit;
  748. end;
  749. end;
  750. end;
  751. procedure tppufile.NewEntry;
  752. begin
  753. with entry do
  754. begin
  755. id:=entrytyp;
  756. nr:=ibend;
  757. size:=0;
  758. end;
  759. {Reset Entry State}
  760. entryidx:=0;
  761. entrybufstart:=bufstart;
  762. entrystart:=bufstart+bufidx;
  763. {Alloc in buffer}
  764. writedata(entry,sizeof(tppuentry));
  765. end;
  766. procedure tppufile.writeentry(ibnr:byte);
  767. var
  768. opos : integer;
  769. begin
  770. {create entry}
  771. entry.id:=entrytyp;
  772. entry.nr:=ibnr;
  773. entry.size:=entryidx;
  774. {it's already been sent to disk ?}
  775. if entrybufstart<>bufstart then
  776. begin
  777. if not crc_only then
  778. begin
  779. {flush to be sure}
  780. WriteBuf;
  781. {write entry}
  782. opos:=filepos(f);
  783. seek(f,entrystart);
  784. blockwrite(f,entry,sizeof(tppuentry));
  785. seek(f,opos);
  786. end;
  787. entrybufstart:=bufstart;
  788. end
  789. else
  790. move(entry,buf[entrystart-bufstart],sizeof(entry));
  791. {Add New Entry, which is ibend by default}
  792. entrystart:=bufstart+bufidx; {next entry position}
  793. NewEntry;
  794. end;
  795. procedure tppufile.putdata(const b;len:integer);
  796. begin
  797. if do_crc then
  798. begin
  799. crc:=UpdateCrc32(crc,b,len);
  800. {$ifdef Test_Double_checksum}
  801. if crc_only then
  802. begin
  803. crc_test2^[crc_index2]:=crc;
  804. {$ifdef Test_Double_checksum_write}
  805. Writeln(CRCFile,crc);
  806. {$endif Test_Double_checksum_write}
  807. if crc_index2<crc_array_size then
  808. inc(crc_index2);
  809. end
  810. else
  811. begin
  812. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  813. (crc_test2^[crcindex2]<>crc) then
  814. Do_comment(V_Note,'impl CRC changed');
  815. {$ifdef Test_Double_checksum_write}
  816. Writeln(CRCFile,crc);
  817. {$endif Test_Double_checksum_write}
  818. inc(crcindex2);
  819. end;
  820. {$endif def Test_Double_checksum}
  821. if do_interface_crc then
  822. begin
  823. interface_crc:=UpdateCrc32(interface_crc,b,len);
  824. {$ifdef Test_Double_checksum}
  825. if crc_only then
  826. begin
  827. crc_test^[crc_index]:=interface_crc;
  828. {$ifdef Test_Double_checksum_write}
  829. Writeln(CRCFile,interface_crc);
  830. {$endif Test_Double_checksum_write}
  831. if crc_index<crc_array_size then
  832. inc(crc_index);
  833. end
  834. else
  835. begin
  836. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  837. (crc_test^[crcindex]<>interface_crc) then
  838. Do_comment(V_Warning,'CRC changed');
  839. {$ifdef Test_Double_checksum_write}
  840. Writeln(CRCFile,interface_crc);
  841. {$endif Test_Double_checksum_write}
  842. inc(crcindex);
  843. end;
  844. {$endif def Test_Double_checksum}
  845. end;
  846. end;
  847. if not crc_only then
  848. writedata(b,len);
  849. inc(entryidx,len);
  850. end;
  851. procedure tppufile.putbyte(b:byte);
  852. begin
  853. putdata(b,1);
  854. end;
  855. procedure tppufile.putword(w:word);
  856. begin
  857. putdata(w,2);
  858. end;
  859. procedure tppufile.putlongint(l:longint);
  860. begin
  861. putdata(l,4);
  862. end;
  863. procedure tppufile.putint64(i:int64);
  864. begin
  865. putdata(i,8);
  866. end;
  867. procedure tppufile.putaint(i:aint);
  868. begin
  869. putdata(i,sizeof(aint));
  870. end;
  871. procedure tppufile.putreal(d:ppureal);
  872. begin
  873. putdata(d,sizeof(ppureal));
  874. end;
  875. procedure tppufile.putstring(s:string);
  876. begin
  877. putdata(s,length(s)+1);
  878. end;
  879. procedure tppufile.putsmallset(const b);
  880. var
  881. l : longint;
  882. begin
  883. l:=longint(b);
  884. putlongint(l);
  885. end;
  886. procedure tppufile.putnormalset(const b);
  887. type
  888. SetLongintArray = Array [0..7] of longint;
  889. var
  890. i : longint;
  891. tempb : setlongintarray;
  892. begin
  893. if change_endian then
  894. begin
  895. for i:=0 to 7 do
  896. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  897. putdata(tempb,32);
  898. end
  899. else
  900. putdata(b,32);
  901. end;
  902. procedure tppufile.tempclose;
  903. begin
  904. if not closed then
  905. begin
  906. closepos:=filepos(f);
  907. {$I-}
  908. system.close(f);
  909. {$I+}
  910. if ioresult<>0 then;
  911. closed:=true;
  912. tempclosed:=true;
  913. end;
  914. end;
  915. function tppufile.tempopen:boolean;
  916. var
  917. ofm : byte;
  918. begin
  919. tempopen:=false;
  920. if not closed or not tempclosed then
  921. exit;
  922. ofm:=filemode;
  923. filemode:=0;
  924. {$I-}
  925. reset(f,1);
  926. {$I+}
  927. filemode:=ofm;
  928. if ioresult<>0 then
  929. exit;
  930. closed:=false;
  931. tempclosed:=false;
  932. { restore state }
  933. seek(f,closepos);
  934. tempopen:=true;
  935. end;
  936. end.
  937. {
  938. $Log$
  939. Revision 1.56 2004-08-27 21:59:26 peter
  940. browser disabled
  941. uf_local_symtable ppu flag when a localsymtable is stored
  942. Revision 1.55 2004/08/22 20:11:38 florian
  943. * morphos now takes any pointer var. as libbase
  944. * alignment for sparc fixed
  945. * int -> double conversion on sparc fixed
  946. Revision 1.54 2004/08/17 16:29:21 jonas
  947. + padalgingment field for recordsymtables (saved by recorddefs)
  948. + support for Macintosh PowerPC alignment (if the first field of a record
  949. or union has an alignment > 4, then the record or union size must be
  950. padded to a multiple of this size)
  951. Revision 1.53 2004/07/12 09:14:04 jonas
  952. * inline procedures at the node tree level, but only under some very
  953. limited circumstances for now (only procedures, and only if they have
  954. no or only vs_out/vs_var parameters).
  955. * fixed ppudump for inline procedures
  956. * fixed ppudump for ppc
  957. Revision 1.52 2004/07/09 23:11:05 peter
  958. * new format
  959. Revision 1.51 2004/06/20 08:55:30 florian
  960. * logs truncated
  961. Revision 1.50 2004/06/16 20:07:09 florian
  962. * dwarf branch merged
  963. Revision 1.49 2004/05/19 21:16:13 peter
  964. * add DEBUGINFO symbol to reference the .o file that includes the
  965. stabs info for types and global/static variables
  966. * debuginfo flag added to ppu to indicate whether debuginfo is
  967. generated or not
  968. Revision 1.48 2004/04/29 19:56:37 daniel
  969. * Prepare compiler infrastructure for multiple ansistring types
  970. Revision 1.47.2.1 2004/05/01 16:02:09 peter
  971. * POINTER_SIZE replaced with sizeof(aint)
  972. * aint,aword,tconst*int moved to globtype
  973. Revision 1.47 2004/03/23 22:34:49 peter
  974. * constants ordinals now always have a type assigned
  975. * integer constants have the smallest type, unsigned prefered over
  976. signed
  977. }