ppu.pas 26 KB

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