ppu.pas 25 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088
  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. crc;
  226. {*****************************************************************************
  227. Endian Handling
  228. *****************************************************************************}
  229. Function SwapLong(x : longint): longint;
  230. var
  231. y : word;
  232. z : word;
  233. Begin
  234. y := (x shr 16) and $FFFF;
  235. y := (y shl 8) or ((y shr 8) and $ff);
  236. z := x and $FFFF;
  237. z := (z shl 8) or ((z shr 8) and $ff);
  238. SwapLong := (longint(z) shl 16) or longint(y);
  239. End;
  240. Function SwapWord(x : word): word;
  241. var
  242. z : byte;
  243. Begin
  244. z := (x shr 8) and $ff;
  245. x := x and $ff;
  246. x := (x shl 8);
  247. SwapWord := x or z;
  248. End;
  249. {*****************************************************************************
  250. TPPUFile
  251. *****************************************************************************}
  252. constructor tppufile.Create(const fn:string);
  253. begin
  254. fname:=fn;
  255. change_endian:=false;
  256. crc_only:=false;
  257. Mode:=0;
  258. NewHeader;
  259. Error:=false;
  260. closed:=true;
  261. tempclosed:=false;
  262. getmem(buf,ppubufsize);
  263. end;
  264. destructor tppufile.destroy;
  265. begin
  266. closefile;
  267. if assigned(buf) then
  268. freemem(buf,ppubufsize);
  269. end;
  270. procedure tppufile.flush;
  271. begin
  272. if Mode=2 then
  273. writebuf;
  274. end;
  275. procedure tppufile.closefile;
  276. begin
  277. {$ifdef Test_Double_checksum}
  278. if mode=2 then
  279. begin
  280. if assigned(crc_test) then
  281. dispose(crc_test);
  282. if assigned(crc_test2) then
  283. dispose(crc_test2);
  284. end;
  285. {$endif Test_Double_checksum}
  286. if Mode<>0 then
  287. begin
  288. Flush;
  289. {$I-}
  290. system.close(f);
  291. {$I+}
  292. if ioresult<>0 then;
  293. Mode:=0;
  294. closed:=true;
  295. end;
  296. end;
  297. function tppufile.CheckPPUId:boolean;
  298. begin
  299. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  300. end;
  301. function tppufile.GetPPUVersion:integer;
  302. var
  303. l : integer;
  304. code : integer;
  305. begin
  306. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  307. if code=0 then
  308. GetPPUVersion:=l
  309. else
  310. GetPPUVersion:=0;
  311. end;
  312. procedure tppufile.NewHeader;
  313. var
  314. s : string;
  315. begin
  316. fillchar(header,sizeof(tppuheader),0);
  317. str(currentppuversion,s);
  318. while length(s)<3 do
  319. s:='0'+s;
  320. with header do
  321. begin
  322. Id[1]:='P';
  323. Id[2]:='P';
  324. Id[3]:='U';
  325. Ver[1]:=s[1];
  326. Ver[2]:=s[2];
  327. Ver[3]:=s[3];
  328. end;
  329. end;
  330. {*****************************************************************************
  331. TPPUFile Reading
  332. *****************************************************************************}
  333. function tppufile.openfile:boolean;
  334. var
  335. ofmode : byte;
  336. i : integer;
  337. begin
  338. openfile:=false;
  339. assign(f,fname);
  340. ofmode:=filemode;
  341. filemode:=$0;
  342. {$I-}
  343. reset(f,1);
  344. {$I+}
  345. filemode:=ofmode;
  346. if ioresult<>0 then
  347. exit;
  348. closed:=false;
  349. {read ppuheader}
  350. fsize:=filesize(f);
  351. if fsize<sizeof(tppuheader) then
  352. exit;
  353. blockread(f,header,sizeof(tppuheader),i);
  354. { The header is always stored in little endian order }
  355. { therefore swap if on a big endian machine }
  356. {$IFDEF ENDIAN_BIG}
  357. header.compiler := SwapWord(header.compiler);
  358. header.cpu := SwapWord(header.cpu);
  359. header.target := SwapWord(header.target);
  360. header.flags := SwapLong(header.flags);
  361. header.size := SwapLong(header.size);
  362. header.checksum := SwapLong(header.checksum);
  363. header.interface_checksum := SwapLong(header.interface_checksum);
  364. {$ENDIF}
  365. { the PPU DATA is stored in native order }
  366. if (header.flags and uf_big_endian) = uf_big_endian then
  367. Begin
  368. {$IFDEF ENDIAN_LITTLE}
  369. change_endian := TRUE;
  370. {$ELSE}
  371. change_endian := FALSE;
  372. {$ENDIF}
  373. End
  374. else if (header.flags and uf_little_endian) = uf_little_endian then
  375. Begin
  376. {$IFDEF ENDIAN_BIG}
  377. change_endian := TRUE;
  378. {$ELSE}
  379. change_endian := FALSE;
  380. {$ENDIF}
  381. End;
  382. {reset buffer}
  383. bufstart:=i;
  384. bufsize:=0;
  385. bufidx:=0;
  386. Mode:=1;
  387. FillChar(entry,sizeof(tppuentry),0);
  388. entryidx:=0;
  389. entrystart:=0;
  390. entrybufstart:=0;
  391. Error:=false;
  392. openfile:=true;
  393. end;
  394. procedure tppufile.reloadbuf;
  395. begin
  396. inc(bufstart,bufsize);
  397. blockread(f,buf^,ppubufsize,bufsize);
  398. bufidx:=0;
  399. end;
  400. procedure tppufile.readdata(var b;len:integer);
  401. var
  402. p : pchar;
  403. left,
  404. idx : integer;
  405. begin
  406. p:=pchar(@b);
  407. idx:=0;
  408. while len>0 do
  409. begin
  410. left:=bufsize-bufidx;
  411. if len>left then
  412. begin
  413. move(buf[bufidx],p[idx],left);
  414. dec(len,left);
  415. inc(idx,left);
  416. reloadbuf;
  417. if bufsize=0 then
  418. exit;
  419. end
  420. else
  421. begin
  422. move(buf[bufidx],p[idx],len);
  423. inc(bufidx,len);
  424. exit;
  425. end;
  426. end;
  427. end;
  428. procedure tppufile.skipdata(len:integer);
  429. var
  430. left : integer;
  431. begin
  432. while len>0 do
  433. begin
  434. left:=bufsize-bufidx;
  435. if len>left then
  436. begin
  437. dec(len,left);
  438. reloadbuf;
  439. if bufsize=0 then
  440. exit;
  441. end
  442. else
  443. begin
  444. inc(bufidx,len);
  445. exit;
  446. end;
  447. end;
  448. end;
  449. function tppufile.readentry:byte;
  450. begin
  451. if entryidx<entry.size then
  452. skipdata(entry.size-entryidx);
  453. readdata(entry,sizeof(tppuentry));
  454. entrystart:=bufstart+bufidx;
  455. entryidx:=0;
  456. if not(entry.id in [mainentryid,subentryid]) then
  457. begin
  458. readentry:=iberror;
  459. error:=true;
  460. exit;
  461. end;
  462. readentry:=entry.nr;
  463. end;
  464. function tppufile.endofentry:boolean;
  465. begin
  466. endofentry:=(entryidx>=entry.size);
  467. end;
  468. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  469. begin
  470. if entryidx+len>entry.size then
  471. res:=entry.size-entryidx
  472. else
  473. res:=len;
  474. readdata(b,res);
  475. inc(entryidx,res);
  476. end;
  477. procedure tppufile.getdata(var b;len:integer);
  478. begin
  479. if entryidx+len>entry.size then
  480. begin
  481. error:=true;
  482. exit;
  483. end;
  484. readdata(b,len);
  485. inc(entryidx,len);
  486. end;
  487. function tppufile.getbyte:byte;
  488. var
  489. b : byte;
  490. begin
  491. if entryidx+1>entry.size then
  492. begin
  493. error:=true;
  494. getbyte:=0;
  495. exit;
  496. end;
  497. readdata(b,1);
  498. getbyte:=b;
  499. inc(entryidx);
  500. end;
  501. function tppufile.getword:word;
  502. var
  503. w : word;
  504. begin
  505. if entryidx+2>entry.size then
  506. begin
  507. error:=true;
  508. getword:=0;
  509. exit;
  510. end;
  511. readdata(w,2);
  512. if change_endian then
  513. getword:=swapword(w)
  514. else
  515. getword:=w;
  516. inc(entryidx,2);
  517. end;
  518. function tppufile.getlongint:longint;
  519. var
  520. l : longint;
  521. begin
  522. if entryidx+4>entry.size then
  523. begin
  524. error:=true;
  525. getlongint:=0;
  526. exit;
  527. end;
  528. readdata(l,4);
  529. if change_endian then
  530. getlongint:=swaplong(l)
  531. else
  532. getlongint:=l;
  533. inc(entryidx,4);
  534. end;
  535. function tppufile.getreal:ppureal;
  536. var
  537. d : ppureal;
  538. begin
  539. if entryidx+sizeof(ppureal)>entry.size then
  540. begin
  541. error:=true;
  542. getreal:=0;
  543. exit;
  544. end;
  545. readdata(d,sizeof(ppureal));
  546. getreal:=d;
  547. inc(entryidx,sizeof(ppureal));
  548. end;
  549. function tppufile.getstring:string;
  550. var
  551. s : string;
  552. begin
  553. s[0]:=chr(getbyte);
  554. if entryidx+length(s)>entry.size then
  555. begin
  556. error:=true;
  557. exit;
  558. end;
  559. ReadData(s[1],length(s));
  560. getstring:=s;
  561. inc(entryidx,length(s));
  562. end;
  563. procedure tppufile.getsmallset(var b);
  564. var
  565. l : longint;
  566. begin
  567. l:=getlongint;
  568. longint(b):=l;
  569. end;
  570. procedure tppufile.getnormalset(var b);
  571. type
  572. SetLongintArray = Array [0..7] of longint;
  573. var
  574. i : longint;
  575. begin
  576. if change_endian then
  577. begin
  578. for i:=0 to 7 do
  579. SetLongintArray(b)[i]:=getlongint;
  580. end
  581. else
  582. getdata(b,32);
  583. end;
  584. function tppufile.skipuntilentry(untilb:byte):boolean;
  585. var
  586. b : byte;
  587. begin
  588. repeat
  589. b:=readentry;
  590. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  591. skipuntilentry:=(b=untilb);
  592. end;
  593. {*****************************************************************************
  594. TPPUFile Writing
  595. *****************************************************************************}
  596. function tppufile.createfile:boolean;
  597. begin
  598. createfile:=false;
  599. {$ifdef INTFPPU}
  600. if crc_only then
  601. begin
  602. fname:=fname+'.intf';
  603. crc_only:=false;
  604. end;
  605. {$endif}
  606. if not crc_only then
  607. begin
  608. assign(f,fname);
  609. {$I-}
  610. rewrite(f,1);
  611. {$I+}
  612. if ioresult<>0 then
  613. exit;
  614. Mode:=2;
  615. {write header for sure}
  616. blockwrite(f,header,sizeof(tppuheader));
  617. end;
  618. bufsize:=ppubufsize;
  619. bufstart:=sizeof(tppuheader);
  620. bufidx:=0;
  621. {reset}
  622. crc:=cardinal($ffffffff);
  623. interface_crc:=cardinal($ffffffff);
  624. do_interface_crc:=true;
  625. Error:=false;
  626. do_crc:=true;
  627. size:=0;
  628. entrytyp:=mainentryid;
  629. {start}
  630. NewEntry;
  631. createfile:=true;
  632. end;
  633. procedure tppufile.writeheader;
  634. var
  635. opos : integer;
  636. begin
  637. { flush buffer }
  638. writebuf;
  639. { update size (w/o header!) in the header }
  640. header.size:=bufstart-sizeof(tppuheader);
  641. { set the endian flag }
  642. {$IFDEF SOURCE_BIG_ENDIAN}
  643. header.flags := header.flags or uf_big_endian;
  644. {$ENDIF}
  645. {$IFDEF SOURCE_LITTLE_ENDIAN}
  646. header.flags := header.flags or uf_little_endian;
  647. {$ENDIF}
  648. { Now swap the header in the correct endian (always little endian) }
  649. {$IFDEF SOURCE_BIG_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}
  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.34 2003-04-25 20:59:34 peter
  881. * removed funcretn,funcretsym, function result is now in varsym
  882. and aliases for result and function name are added using absolutesym
  883. * vs_hidden parameter for funcret passed in parameter
  884. * vs_hidden fixes
  885. * writenode changed to printnode and released from extdebug
  886. * -vp option added to generate a tree.log with the nodetree
  887. * nicer printnode for statements, callnode
  888. Revision 1.33 2003/04/24 13:03:01 florian
  889. * comp is now written with its bit pattern to the ppu instead as an extended
  890. Revision 1.32 2003/04/23 14:42:07 daniel
  891. * Further register allocator work. Compiler now smaller with new
  892. allocator than without.
  893. * Somebody forgot to adjust ppu version number
  894. Revision 1.31 2003/04/10 17:57:53 peter
  895. * vs_hidden released
  896. Revision 1.30 2003/03/17 15:54:22 peter
  897. * store symoptions also for procdef
  898. * check symoptions (private,public) when calculating possible
  899. overload candidates
  900. Revision 1.29 2003/01/08 18:43:56 daniel
  901. * Tregister changed into a record
  902. Revision 1.28 2002/11/15 01:58:53 peter
  903. * merged changes from 1.0.7 up to 04-11
  904. - -V option for generating bug report tracing
  905. - more tracing for option parsing
  906. - errors for cdecl and high()
  907. - win32 import stabs
  908. - win32 records<=8 are returned in eax:edx (turned off by default)
  909. - heaptrc update
  910. - more info for temp management in .s file with EXTDEBUG
  911. Revision 1.27 2002/10/14 19:42:33 peter
  912. * only use init tables for threadvars
  913. Revision 1.26 2002/08/18 20:06:25 peter
  914. * inlining is now also allowed in interface
  915. * renamed write/load to ppuwrite/ppuload
  916. * tnode storing in ppu
  917. * nld,ncon,nbas are already updated for storing in ppu
  918. Revision 1.25 2002/08/15 19:10:35 peter
  919. * first things tai,tnode storing in ppu
  920. Revision 1.24 2002/08/15 15:09:42 carl
  921. + fpu emulation helpers (ppu checking also)
  922. Revision 1.23 2002/08/13 21:40:56 florian
  923. * more fixes for ppc calling conventions
  924. Revision 1.22 2002/08/11 13:24:12 peter
  925. * saving of asmsymbols in ppu supported
  926. * asmsymbollist global is removed and moved into a new class
  927. tasmlibrarydata that will hold the info of a .a file which
  928. corresponds with a single module. Added librarydata to tmodule
  929. to keep the library info stored for the module. In the future the
  930. objectfiles will also be stored to the tasmlibrarydata class
  931. * all getlabel/newasmsymbol and friends are moved to the new class
  932. Revision 1.21 2002/08/09 07:33:02 florian
  933. * a couple of interface related fixes
  934. Revision 1.20 2002/05/18 13:34:13 peter
  935. * readded missing revisions
  936. Revision 1.19 2002/05/16 19:46:44 carl
  937. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  938. + try to fix temp allocation (still in ifdef)
  939. + generic constructor calls
  940. + start of tassembler / tmodulebase class cleanup
  941. Revision 1.17 2002/04/04 19:06:03 peter
  942. * removed unused units
  943. * use tlocation.size in cg.a_*loc*() routines
  944. Revision 1.16 2002/03/31 20:26:36 jonas
  945. + a_loadfpu_* and a_loadmm_* methods in tcg
  946. * register allocation is now handled by a class and is mostly processor
  947. independent (+rgobj.pas and i386/rgcpu.pas)
  948. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  949. * some small improvements and fixes to the optimizer
  950. * some register allocation fixes
  951. * some fpuvaroffset fixes in the unary minus node
  952. * push/popusedregisters is now called rg.save/restoreusedregisters and
  953. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  954. also better optimizable)
  955. * fixed and optimized register saving/restoring for new/dispose nodes
  956. * LOC_FPU locations now also require their "register" field to be set to
  957. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  958. - list field removed of the tnode class because it's not used currently
  959. and can cause hard-to-find bugs
  960. Revision 1.15 2002/03/28 16:07:52 armin
  961. + initialize threadvars defined local in units
  962. }