ppu.pas 25 KB

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