ppu.pas 27 KB

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