ppu.pas 24 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115
  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. CurrentPPUVersion=45;
  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. ibglobalvarsym = 22;
  75. ibconstsym = 23;
  76. ibenumsym = 24;
  77. ibtypedconstsym = 25;
  78. ibabsolutevarsym = 26;
  79. ibpropertysym = 27;
  80. ibfieldvarsym = 28;
  81. ibunitsym = 29; { needed for browser }
  82. iblabelsym = 30;
  83. ibsyssym = 31;
  84. ibrttisym = 32;
  85. iblocalvarsym = 33;
  86. ibparavarsym = 34;
  87. {definitions}
  88. iborddef = 40;
  89. ibpointerdef = 41;
  90. ibarraydef = 42;
  91. ibprocdef = 43;
  92. ibshortstringdef = 44;
  93. ibrecorddef = 45;
  94. ibfiledef = 46;
  95. ibformaldef = 47;
  96. ibobjectdef = 48;
  97. ibenumdef = 49;
  98. ibsetdef = 50;
  99. ibprocvardef = 51;
  100. ibfloatdef = 52;
  101. ibclassrefdef = 53;
  102. iblongstringdef = 54;
  103. {$ifdef ansistring_bits}
  104. ibansistring16def = 58;
  105. ibansistring32def = 55;
  106. ibansistring64def = 59;
  107. {$else}
  108. ibansistringdef = 55;
  109. {$endif}
  110. ibwidestringdef = 56;
  111. ibvariantdef = 57;
  112. {implementation/objectdata}
  113. ibnodetree = 80;
  114. ibasmsymbols = 81;
  115. { unit flags }
  116. uf_init = $1;
  117. uf_finalize = $2;
  118. uf_big_endian = $4;
  119. uf_has_dbx = $8;
  120. uf_has_browser = $10;
  121. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  122. uf_smart_linked = $40; { the ppu can be smartlinked }
  123. uf_static_linked = $80; { the ppu can be linked static }
  124. uf_shared_linked = $100; { the ppu can be linked shared }
  125. uf_local_browser = $200;
  126. uf_no_link = $400; { unit has no .o generated, but can still have
  127. external linking! }
  128. uf_has_resources = $800; { unit has resource section }
  129. uf_little_endian = $1000;
  130. uf_release = $2000; { unit was compiled with -Ur option }
  131. uf_threadvars = $4000; { unit has threadvars }
  132. uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
  133. uf_has_debuginfo = $10000; { this unit has debuginfo generated }
  134. uf_local_symtable = $20000; { this unit has a local symtable stored }
  135. type
  136. ppureal=extended;
  137. tppuerror=(ppuentrytoobig,ppuentryerror);
  138. tppuheader=record
  139. id : array[1..3] of char; { = 'PPU' }
  140. ver : array[1..3] of char;
  141. compiler : word;
  142. cpu : word;
  143. target : word;
  144. flags : longint;
  145. size : longint; { size of the ppufile without header }
  146. checksum : cardinal; { checksum for this ppufile }
  147. interface_checksum : cardinal;
  148. future : array[0..2] of longint;
  149. end;
  150. tppuentry=packed record
  151. size : longint;
  152. id : byte;
  153. nr : byte;
  154. end;
  155. tppufile=class
  156. private
  157. f : file;
  158. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  159. fname : string;
  160. fsize : integer;
  161. {$ifdef Test_Double_checksum}
  162. public
  163. crcindex,
  164. crc_index,
  165. crcindex2,
  166. crc_index2 : cardinal;
  167. crc_test,
  168. crc_test2 : pcrc_array;
  169. private
  170. {$endif def Test_Double_checksum}
  171. change_endian : boolean;
  172. buf : pchar;
  173. bufstart,
  174. bufsize,
  175. bufidx : integer;
  176. entrybufstart,
  177. entrystart,
  178. entryidx : integer;
  179. entry : tppuentry;
  180. closed,
  181. tempclosed : boolean;
  182. closepos : integer;
  183. public
  184. entrytyp : byte;
  185. header : tppuheader;
  186. size : integer;
  187. crc,
  188. interface_crc : cardinal;
  189. error,
  190. do_crc,
  191. do_interface_crc : boolean;
  192. crc_only : boolean; { used to calculate interface_crc before implementation }
  193. constructor Create(const fn:string);
  194. destructor Destroy;override;
  195. procedure flush;
  196. procedure closefile;
  197. function CheckPPUId:boolean;
  198. function GetPPUVersion:integer;
  199. procedure NewHeader;
  200. procedure NewEntry;
  201. {read}
  202. function openfile:boolean;
  203. procedure reloadbuf;
  204. procedure readdata(var b;len:integer);
  205. procedure skipdata(len:integer);
  206. function readentry:byte;
  207. function EndOfEntry:boolean;
  208. function entrysize:longint;
  209. procedure getdatabuf(var b;len:integer;var res:integer);
  210. procedure getdata(var b;len:integer);
  211. function getbyte:byte;
  212. function getword:word;
  213. function getlongint:longint;
  214. function getint64:int64;
  215. function getaint:aint;
  216. function getreal:ppureal;
  217. function getstring:string;
  218. procedure getnormalset(var b);
  219. procedure getsmallset(var b);
  220. function skipuntilentry(untilb:byte):boolean;
  221. {write}
  222. function createfile:boolean;
  223. procedure writeheader;
  224. procedure writebuf;
  225. procedure writedata(const b;len:integer);
  226. procedure writeentry(ibnr:byte);
  227. procedure putdata(const b;len:integer);
  228. procedure putbyte(b:byte);
  229. procedure putword(w:word);
  230. procedure putlongint(l:longint);
  231. procedure putint64(i:int64);
  232. procedure putaint(i:aint);
  233. procedure putreal(d:ppureal);
  234. procedure putstring(s:string);
  235. procedure putnormalset(const b);
  236. procedure putsmallset(const b);
  237. procedure tempclose;
  238. function tempopen:boolean;
  239. end;
  240. implementation
  241. uses
  242. {$ifdef Test_Double_checksum}
  243. comphook,
  244. {$endif def Test_Double_checksum}
  245. crc,
  246. cutils;
  247. {*****************************************************************************
  248. Endian Handling
  249. *****************************************************************************}
  250. Function SwapLong(x : longint): longint;
  251. var
  252. y : word;
  253. z : word;
  254. Begin
  255. y := x shr 16;
  256. y := word(longint(y) shl 8) or (y shr 8);
  257. z := x and $FFFF;
  258. z := word(longint(z) shl 8) or (z shr 8);
  259. SwapLong := (longint(z) shl 16) or longint(y);
  260. End;
  261. Function SwapWord(x : word): word;
  262. var
  263. z : byte;
  264. Begin
  265. z := x shr 8;
  266. x := x and $ff;
  267. x := word(x shl 8);
  268. SwapWord := x or z;
  269. End;
  270. {*****************************************************************************
  271. TPPUFile
  272. *****************************************************************************}
  273. constructor tppufile.Create(const fn:string);
  274. begin
  275. fname:=fn;
  276. change_endian:=false;
  277. crc_only:=false;
  278. Mode:=0;
  279. NewHeader;
  280. Error:=false;
  281. closed:=true;
  282. tempclosed:=false;
  283. getmem(buf,ppubufsize);
  284. end;
  285. destructor tppufile.destroy;
  286. begin
  287. closefile;
  288. if assigned(buf) then
  289. freemem(buf,ppubufsize);
  290. end;
  291. procedure tppufile.flush;
  292. begin
  293. if Mode=2 then
  294. writebuf;
  295. end;
  296. procedure tppufile.closefile;
  297. begin
  298. {$ifdef Test_Double_checksum}
  299. if mode=2 then
  300. begin
  301. if assigned(crc_test) then
  302. dispose(crc_test);
  303. if assigned(crc_test2) then
  304. dispose(crc_test2);
  305. end;
  306. {$endif Test_Double_checksum}
  307. if Mode<>0 then
  308. begin
  309. Flush;
  310. {$I-}
  311. system.close(f);
  312. {$I+}
  313. if ioresult<>0 then;
  314. Mode:=0;
  315. closed:=true;
  316. end;
  317. end;
  318. function tppufile.CheckPPUId:boolean;
  319. begin
  320. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  321. end;
  322. function tppufile.GetPPUVersion:integer;
  323. var
  324. l : integer;
  325. code : integer;
  326. begin
  327. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  328. if code=0 then
  329. GetPPUVersion:=l
  330. else
  331. GetPPUVersion:=0;
  332. end;
  333. procedure tppufile.NewHeader;
  334. var
  335. s : string;
  336. begin
  337. fillchar(header,sizeof(tppuheader),0);
  338. str(currentppuversion,s);
  339. while length(s)<3 do
  340. s:='0'+s;
  341. with header do
  342. begin
  343. Id[1]:='P';
  344. Id[2]:='P';
  345. Id[3]:='U';
  346. Ver[1]:=s[1];
  347. Ver[2]:=s[2];
  348. Ver[3]:=s[3];
  349. end;
  350. end;
  351. {*****************************************************************************
  352. TPPUFile Reading
  353. *****************************************************************************}
  354. function tppufile.openfile:boolean;
  355. var
  356. ofmode : byte;
  357. i : integer;
  358. begin
  359. openfile:=false;
  360. assign(f,fname);
  361. ofmode:=filemode;
  362. filemode:=$0;
  363. {$I-}
  364. reset(f,1);
  365. {$I+}
  366. filemode:=ofmode;
  367. if ioresult<>0 then
  368. exit;
  369. closed:=false;
  370. {read ppuheader}
  371. fsize:=filesize(f);
  372. if fsize<sizeof(tppuheader) then
  373. exit;
  374. blockread(f,header,sizeof(tppuheader),i);
  375. { The header is always stored in little endian order }
  376. { therefore swap if on a big endian machine }
  377. {$IFDEF ENDIAN_BIG}
  378. header.compiler := SwapWord(header.compiler);
  379. header.cpu := SwapWord(header.cpu);
  380. header.target := SwapWord(header.target);
  381. header.flags := SwapLong(header.flags);
  382. header.size := SwapLong(header.size);
  383. header.checksum := cardinal(SwapLong(longint(header.checksum)));
  384. header.interface_checksum := cardinal(SwapLong(longint(header.interface_checksum)));
  385. {$ENDIF}
  386. { the PPU DATA is stored in native order }
  387. if (header.flags and uf_big_endian) = uf_big_endian then
  388. Begin
  389. {$IFDEF ENDIAN_LITTLE}
  390. change_endian := TRUE;
  391. {$ELSE}
  392. change_endian := FALSE;
  393. {$ENDIF}
  394. End
  395. else if (header.flags and uf_little_endian) = uf_little_endian then
  396. Begin
  397. {$IFDEF ENDIAN_BIG}
  398. change_endian := TRUE;
  399. {$ELSE}
  400. change_endian := FALSE;
  401. {$ENDIF}
  402. End;
  403. {reset buffer}
  404. bufstart:=i;
  405. bufsize:=0;
  406. bufidx:=0;
  407. Mode:=1;
  408. FillChar(entry,sizeof(tppuentry),0);
  409. entryidx:=0;
  410. entrystart:=0;
  411. entrybufstart:=0;
  412. Error:=false;
  413. openfile:=true;
  414. end;
  415. procedure tppufile.reloadbuf;
  416. begin
  417. inc(bufstart,bufsize);
  418. blockread(f,buf^,ppubufsize,bufsize);
  419. bufidx:=0;
  420. end;
  421. procedure tppufile.readdata(var b;len:integer);
  422. var
  423. p : pchar;
  424. left,
  425. idx : integer;
  426. begin
  427. p:=pchar(@b);
  428. idx:=0;
  429. while len>0 do
  430. begin
  431. left:=bufsize-bufidx;
  432. if len>left then
  433. begin
  434. move(buf[bufidx],p[idx],left);
  435. dec(len,left);
  436. inc(idx,left);
  437. reloadbuf;
  438. if bufsize=0 then
  439. exit;
  440. end
  441. else
  442. begin
  443. move(buf[bufidx],p[idx],len);
  444. inc(bufidx,len);
  445. exit;
  446. end;
  447. end;
  448. end;
  449. procedure tppufile.skipdata(len:integer);
  450. var
  451. left : integer;
  452. begin
  453. while len>0 do
  454. begin
  455. left:=bufsize-bufidx;
  456. if len>left then
  457. begin
  458. dec(len,left);
  459. reloadbuf;
  460. if bufsize=0 then
  461. exit;
  462. end
  463. else
  464. begin
  465. inc(bufidx,len);
  466. exit;
  467. end;
  468. end;
  469. end;
  470. function tppufile.readentry:byte;
  471. begin
  472. if entryidx<entry.size then
  473. skipdata(entry.size-entryidx);
  474. readdata(entry,sizeof(tppuentry));
  475. if change_endian then
  476. entry.size:=swaplong(entry.size);
  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.58 2004-11-08 22:09:59 peter
  940. * tvarsym splitted
  941. Revision 1.57 2004/09/21 17:25:12 peter
  942. * paraloc branch merged
  943. Revision 1.56.4.1 2004/09/12 14:01:23 peter
  944. * entry.size need endian update
  945. Revision 1.56 2004/08/27 21:59:26 peter
  946. browser disabled
  947. uf_local_symtable ppu flag when a localsymtable is stored
  948. Revision 1.55 2004/08/22 20:11:38 florian
  949. * morphos now takes any pointer var. as libbase
  950. * alignment for sparc fixed
  951. * int -> double conversion on sparc fixed
  952. Revision 1.54 2004/08/17 16:29:21 jonas
  953. + padalgingment field for recordsymtables (saved by recorddefs)
  954. + support for Macintosh PowerPC alignment (if the first field of a record
  955. or union has an alignment > 4, then the record or union size must be
  956. padded to a multiple of this size)
  957. Revision 1.53 2004/07/12 09:14:04 jonas
  958. * inline procedures at the node tree level, but only under some very
  959. limited circumstances for now (only procedures, and only if they have
  960. no or only vs_out/vs_var parameters).
  961. * fixed ppudump for inline procedures
  962. * fixed ppudump for ppc
  963. Revision 1.52 2004/07/09 23:11:05 peter
  964. * new format
  965. Revision 1.51 2004/06/20 08:55:30 florian
  966. * logs truncated
  967. Revision 1.50 2004/06/16 20:07:09 florian
  968. * dwarf branch merged
  969. Revision 1.49 2004/05/19 21:16:13 peter
  970. * add DEBUGINFO symbol to reference the .o file that includes the
  971. stabs info for types and global/static variables
  972. * debuginfo flag added to ppu to indicate whether debuginfo is
  973. generated or not
  974. Revision 1.48 2004/04/29 19:56:37 daniel
  975. * Prepare compiler infrastructure for multiple ansistring types
  976. Revision 1.47.2.1 2004/05/01 16:02:09 peter
  977. * POINTER_SIZE replaced with sizeof(aint)
  978. * aint,aword,tconst*int moved to globtype
  979. Revision 1.47 2004/03/23 22:34:49 peter
  980. * constants ordinals now always have a type assigned
  981. * integer constants have the smallest type, unsigned prefered over
  982. signed
  983. }