ppu.pas 22 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 defines.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=22;
  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. ibfuncretsym = 31;
  81. ibsyssym = 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. { unit flags }
  102. uf_init = $1;
  103. uf_finalize = $2;
  104. uf_big_endian = $4;
  105. uf_has_dbx = $8;
  106. uf_has_browser = $10;
  107. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  108. uf_smart_linked = $40; { the ppu can be smartlinked }
  109. uf_static_linked = $80; { the ppu can be linked static }
  110. uf_shared_linked = $100; { the ppu can be linked shared }
  111. uf_local_browser = $200;
  112. uf_no_link = $400; { unit has no .o generated, but can still have
  113. external linking! }
  114. uf_has_resources = $800; { unit has resource section }
  115. uf_little_endian = $1000;
  116. uf_release = $2000;{ unit was compiled with -Ur option }
  117. type
  118. ppureal=extended;
  119. tppuerror=(ppuentrytoobig,ppuentryerror);
  120. tppuheader=packed record { 40 bytes }
  121. id : array[1..3] of char; { = 'PPU' }
  122. ver : array[1..3] of char;
  123. compiler : word;
  124. cpu : word;
  125. target : word;
  126. flags : longint;
  127. size : longint; { size of the ppufile without header }
  128. checksum : cardinal; { checksum for this ppufile }
  129. interface_checksum : cardinal;
  130. future : array[0..2] of longint;
  131. end;
  132. tppuentry=packed record
  133. id : byte;
  134. nr : byte;
  135. size : longint;
  136. end;
  137. tppufile=class
  138. private
  139. f : file;
  140. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  141. fname : string;
  142. fsize : integer;
  143. {$ifdef Test_Double_checksum}
  144. crcindex,
  145. crc_index,
  146. crcindex2,
  147. crc_index2 : cardinal;
  148. crc_test,
  149. crc_test2 : pcrc_array;
  150. {$endif def Test_Double_checksum}
  151. change_endian : boolean;
  152. buf : pchar;
  153. bufstart,
  154. bufsize,
  155. bufidx : integer;
  156. entrybufstart,
  157. entrystart,
  158. entryidx : integer;
  159. entry : tppuentry;
  160. closed,
  161. tempclosed : boolean;
  162. closepos : integer;
  163. public
  164. entrytyp : byte;
  165. header : tppuheader;
  166. size : integer;
  167. crc,
  168. interface_crc : cardinal;
  169. error,
  170. do_crc,
  171. do_interface_crc : boolean;
  172. crc_only : boolean; { used to calculate interface_crc before implementation }
  173. constructor Create(const fn:string);
  174. destructor Destroy;override;
  175. procedure flush;
  176. procedure closefile;
  177. function CheckPPUId:boolean;
  178. function GetPPUVersion:integer;
  179. procedure NewHeader;
  180. procedure NewEntry;
  181. {read}
  182. function openfile:boolean;
  183. procedure reloadbuf;
  184. procedure readdata(var b;len:integer);
  185. procedure skipdata(len:integer);
  186. function readentry:byte;
  187. function EndOfEntry:boolean;
  188. procedure getdatabuf(var b;len:integer;var res:integer);
  189. procedure getdata(var b;len:integer);
  190. function getbyte:byte;
  191. function getword:word;
  192. function getlongint:longint;
  193. function getreal:ppureal;
  194. function getstring:string;
  195. procedure getnormalset(var b);
  196. procedure getsmallset(var b);
  197. function skipuntilentry(untilb:byte):boolean;
  198. {write}
  199. function createfile:boolean;
  200. procedure writeheader;
  201. procedure writebuf;
  202. procedure writedata(const b;len:integer);
  203. procedure writeentry(ibnr:byte);
  204. procedure putdata(const b;len:integer);
  205. procedure putbyte(b:byte);
  206. procedure putword(w:word);
  207. procedure putlongint(l:longint);
  208. procedure putreal(d:ppureal);
  209. procedure putstring(s:string);
  210. procedure putnormalset(const b);
  211. procedure putsmallset(const b);
  212. procedure tempclose;
  213. function tempopen:boolean;
  214. end;
  215. implementation
  216. uses
  217. {$ifdef Test_Double_checksum}
  218. comphook,
  219. {$endif def Test_Double_checksum}
  220. crc;
  221. {*****************************************************************************
  222. Endian Handling
  223. *****************************************************************************}
  224. Function SwapLong(x : longint): longint;
  225. var
  226. y : word;
  227. z : word;
  228. Begin
  229. y := (x shr 16) and $FFFF;
  230. y := (y shl 8) or ((y shr 8) and $ff);
  231. z := x and $FFFF;
  232. z := (z shl 8) or ((z shr 8) and $ff);
  233. SwapLong := (longint(z) shl 16) or longint(y);
  234. End;
  235. Function SwapWord(x : word): word;
  236. var
  237. z : byte;
  238. Begin
  239. z := (x shr 8) and $ff;
  240. x := x and $ff;
  241. x := (x shl 8);
  242. SwapWord := x or z;
  243. End;
  244. {*****************************************************************************
  245. TPPUFile
  246. *****************************************************************************}
  247. constructor tppufile.Create(const fn:string);
  248. begin
  249. fname:=fn;
  250. change_endian:=false;
  251. crc_only:=false;
  252. Mode:=0;
  253. NewHeader;
  254. Error:=false;
  255. closed:=true;
  256. tempclosed:=false;
  257. getmem(buf,ppubufsize);
  258. end;
  259. destructor tppufile.destroy;
  260. begin
  261. closefile;
  262. if assigned(buf) then
  263. freemem(buf,ppubufsize);
  264. end;
  265. procedure tppufile.flush;
  266. begin
  267. if Mode=2 then
  268. writebuf;
  269. end;
  270. procedure tppufile.closefile;
  271. begin
  272. {$ifdef Test_Double_checksum}
  273. if mode=2 then
  274. begin
  275. if assigned(crc_test) then
  276. dispose(crc_test);
  277. if assigned(crc_test2) then
  278. dispose(crc_test2);
  279. end;
  280. {$endif Test_Double_checksum}
  281. if Mode<>0 then
  282. begin
  283. Flush;
  284. {$I-}
  285. system.close(f);
  286. {$I+}
  287. if ioresult<>0 then;
  288. Mode:=0;
  289. closed:=true;
  290. end;
  291. end;
  292. function tppufile.CheckPPUId:boolean;
  293. begin
  294. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  295. end;
  296. function tppufile.GetPPUVersion:integer;
  297. var
  298. l : integer;
  299. code : integer;
  300. begin
  301. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  302. if code=0 then
  303. GetPPUVersion:=l
  304. else
  305. GetPPUVersion:=0;
  306. end;
  307. procedure tppufile.NewHeader;
  308. var
  309. s : string;
  310. begin
  311. fillchar(header,sizeof(tppuheader),0);
  312. str(currentppuversion,s);
  313. while length(s)<3 do
  314. s:='0'+s;
  315. with header do
  316. begin
  317. Id[1]:='P';
  318. Id[2]:='P';
  319. Id[3]:='U';
  320. Ver[1]:=s[1];
  321. Ver[2]:=s[2];
  322. Ver[3]:=s[3];
  323. end;
  324. end;
  325. {*****************************************************************************
  326. TPPUFile Reading
  327. *****************************************************************************}
  328. function tppufile.openfile:boolean;
  329. var
  330. ofmode : byte;
  331. i : integer;
  332. begin
  333. openfile:=false;
  334. assign(f,fname);
  335. ofmode:=filemode;
  336. filemode:=$0;
  337. {$I-}
  338. reset(f,1);
  339. {$I+}
  340. filemode:=ofmode;
  341. if ioresult<>0 then
  342. exit;
  343. closed:=false;
  344. {read ppuheader}
  345. fsize:=filesize(f);
  346. if fsize<sizeof(tppuheader) then
  347. exit;
  348. blockread(f,header,sizeof(tppuheader),i);
  349. { The header is always stored in little endian order }
  350. { therefore swap if on a big endian machine }
  351. {$IFDEF ENDIAN_BIG}
  352. header.compiler := SwapWord(header.compiler);
  353. header.cpu := SwapWord(header.cpu);
  354. header.target := SwapWord(header.target);
  355. header.flags := SwapLong(header.flags);
  356. header.size := SwapLong(header.size);
  357. header.checksum := SwapLong(header.checksum);
  358. header.interface_checksum := SwapLong(header.interface_checksum);
  359. {$ENDIF}
  360. { the PPU DATA is stored in native order }
  361. if (header.flags and uf_big_endian) = uf_big_endian then
  362. Begin
  363. {$IFDEF ENDIAN_LITTLE}
  364. change_endian := TRUE;
  365. {$ELSE}
  366. change_endian := FALSE;
  367. {$ENDIF}
  368. End
  369. else if (header.flags and uf_little_endian) = uf_little_endian then
  370. Begin
  371. {$IFDEF ENDIAN_BIG}
  372. change_endian := TRUE;
  373. {$ELSE}
  374. change_endian := FALSE;
  375. {$ENDIF}
  376. End;
  377. {reset buffer}
  378. bufstart:=i;
  379. bufsize:=0;
  380. bufidx:=0;
  381. Mode:=1;
  382. FillChar(entry,sizeof(tppuentry),0);
  383. entryidx:=0;
  384. entrystart:=0;
  385. entrybufstart:=0;
  386. Error:=false;
  387. openfile:=true;
  388. end;
  389. procedure tppufile.reloadbuf;
  390. begin
  391. inc(bufstart,bufsize);
  392. blockread(f,buf^,ppubufsize,bufsize);
  393. bufidx:=0;
  394. end;
  395. procedure tppufile.readdata(var b;len:integer);
  396. var
  397. p : pchar;
  398. left,
  399. idx : integer;
  400. begin
  401. p:=pchar(@b);
  402. idx:=0;
  403. while len>0 do
  404. begin
  405. left:=bufsize-bufidx;
  406. if len>left then
  407. begin
  408. move(buf[bufidx],p[idx],left);
  409. dec(len,left);
  410. inc(idx,left);
  411. reloadbuf;
  412. if bufsize=0 then
  413. exit;
  414. end
  415. else
  416. begin
  417. move(buf[bufidx],p[idx],len);
  418. inc(bufidx,len);
  419. exit;
  420. end;
  421. end;
  422. end;
  423. procedure tppufile.skipdata(len:integer);
  424. var
  425. left : integer;
  426. begin
  427. while len>0 do
  428. begin
  429. left:=bufsize-bufidx;
  430. if len>left then
  431. begin
  432. dec(len,left);
  433. reloadbuf;
  434. if bufsize=0 then
  435. exit;
  436. end
  437. else
  438. begin
  439. inc(bufidx,len);
  440. exit;
  441. end;
  442. end;
  443. end;
  444. function tppufile.readentry:byte;
  445. begin
  446. if entryidx<entry.size then
  447. skipdata(entry.size-entryidx);
  448. readdata(entry,sizeof(tppuentry));
  449. entrystart:=bufstart+bufidx;
  450. entryidx:=0;
  451. if not(entry.id in [mainentryid,subentryid]) then
  452. begin
  453. readentry:=iberror;
  454. error:=true;
  455. exit;
  456. end;
  457. readentry:=entry.nr;
  458. end;
  459. function tppufile.endofentry:boolean;
  460. begin
  461. endofentry:=(entryidx>=entry.size);
  462. end;
  463. procedure tppufile.getdatabuf(var b;len:integer;var res:integer);
  464. begin
  465. if entryidx+len>entry.size then
  466. res:=entry.size-entryidx
  467. else
  468. res:=len;
  469. readdata(b,res);
  470. inc(entryidx,res);
  471. end;
  472. procedure tppufile.getdata(var b;len:integer);
  473. begin
  474. if entryidx+len>entry.size then
  475. begin
  476. error:=true;
  477. exit;
  478. end;
  479. readdata(b,len);
  480. inc(entryidx,len);
  481. end;
  482. function tppufile.getbyte:byte;
  483. var
  484. b : byte;
  485. begin
  486. if entryidx+1>entry.size then
  487. begin
  488. error:=true;
  489. getbyte:=0;
  490. exit;
  491. end;
  492. readdata(b,1);
  493. getbyte:=b;
  494. inc(entryidx);
  495. end;
  496. function tppufile.getword:word;
  497. type
  498. pword = ^word;
  499. var
  500. w : word;
  501. begin
  502. if entryidx+2>entry.size then
  503. begin
  504. error:=true;
  505. getword:=0;
  506. exit;
  507. end;
  508. readdata(w,2);
  509. if change_endian then
  510. getword:=swapword(w)
  511. else
  512. getword:=w;
  513. inc(entryidx,2);
  514. end;
  515. function tppufile.getlongint:longint;
  516. type
  517. plongint = ^longint;
  518. var
  519. l : longint;
  520. begin
  521. if entryidx+4>entry.size then
  522. begin
  523. error:=true;
  524. getlongint:=0;
  525. exit;
  526. end;
  527. readdata(l,4);
  528. if change_endian then
  529. getlongint:=swaplong(l)
  530. else
  531. getlongint:=l;
  532. inc(entryidx,4);
  533. end;
  534. function tppufile.getreal:ppureal;
  535. type
  536. pppureal = ^ppureal;
  537. var
  538. d : ppureal;
  539. begin
  540. if entryidx+sizeof(ppureal)>entry.size then
  541. begin
  542. error:=true;
  543. getreal:=0;
  544. exit;
  545. end;
  546. readdata(d,sizeof(ppureal));
  547. getreal:=d;
  548. inc(entryidx,sizeof(ppureal));
  549. end;
  550. function tppufile.getstring:string;
  551. var
  552. s : string;
  553. begin
  554. s[0]:=chr(getbyte);
  555. if entryidx+length(s)>entry.size then
  556. begin
  557. error:=true;
  558. exit;
  559. end;
  560. ReadData(s[1],length(s));
  561. getstring:=s;
  562. inc(entryidx,length(s));
  563. end;
  564. procedure tppufile.getsmallset(var b);
  565. var
  566. l : longint;
  567. begin
  568. l:=getlongint;
  569. longint(b):=l;
  570. end;
  571. procedure tppufile.getnormalset(var b);
  572. type
  573. SetLongintArray = Array [0..7] of longint;
  574. var
  575. i : longint;
  576. begin
  577. if change_endian then
  578. begin
  579. for i:=0 to 7 do
  580. SetLongintArray(b)[i]:=getlongint;
  581. end
  582. else
  583. getdata(b,32);
  584. end;
  585. function tppufile.skipuntilentry(untilb:byte):boolean;
  586. var
  587. b : byte;
  588. begin
  589. repeat
  590. b:=readentry;
  591. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  592. skipuntilentry:=(b=untilb);
  593. end;
  594. {*****************************************************************************
  595. TPPUFile Writing
  596. *****************************************************************************}
  597. function tppufile.createfile:boolean;
  598. begin
  599. createfile:=false;
  600. {$ifdef INTFPPU}
  601. if crc_only then
  602. begin
  603. fname:=fname+'.intf';
  604. crc_only:=false;
  605. end;
  606. {$endif}
  607. if not crc_only then
  608. begin
  609. assign(f,fname);
  610. {$I-}
  611. rewrite(f,1);
  612. {$I+}
  613. if ioresult<>0 then
  614. exit;
  615. Mode:=2;
  616. {write header for sure}
  617. blockwrite(f,header,sizeof(tppuheader));
  618. end;
  619. bufsize:=ppubufsize;
  620. bufstart:=sizeof(tppuheader);
  621. bufidx:=0;
  622. {reset}
  623. crc:=cardinal($ffffffff);
  624. interface_crc:=cardinal($ffffffff);
  625. do_interface_crc:=true;
  626. Error:=false;
  627. do_crc:=true;
  628. size:=0;
  629. entrytyp:=mainentryid;
  630. {start}
  631. NewEntry;
  632. createfile:=true;
  633. end;
  634. procedure tppufile.writeheader;
  635. var
  636. opos : integer;
  637. begin
  638. { flush buffer }
  639. writebuf;
  640. { update size (w/o header!) in the header }
  641. header.size:=bufstart-sizeof(tppuheader);
  642. { set the endian flag }
  643. {$IFDEF SOURCE_BIG_ENDIAN}
  644. header.flags := header.flags or uf_big_endian;
  645. {$ENDIF}
  646. {$IFDEF SOURCE_LITTLE_ENDIAN}
  647. header.flags := header.flags or uf_little_endian;
  648. {$ENDIF}
  649. { Now swap the header in the correct endian (always little endian) }
  650. {$IFDEF SOURCE_BIG_ENDIAN}
  651. header.compiler := SwapWord(header.compiler);
  652. header.cpu := SwapWord(header.cpu);
  653. header.target := SwapWord(header.target);
  654. header.flags := SwapLong(header.flags);
  655. header.size := SwapLong(header.size);
  656. header.checksum := SwapLong(header.checksum);
  657. header.interface_checksum := SwapLong(header.interface_checksum);
  658. {$ENDIF}
  659. { write header and restore filepos after it }
  660. opos:=filepos(f);
  661. seek(f,0);
  662. blockwrite(f,header,sizeof(tppuheader));
  663. seek(f,opos);
  664. end;
  665. procedure tppufile.writebuf;
  666. begin
  667. if not crc_only then
  668. blockwrite(f,buf^,bufidx);
  669. inc(bufstart,bufidx);
  670. bufidx:=0;
  671. end;
  672. procedure tppufile.writedata(const b;len:integer);
  673. var
  674. p : pchar;
  675. left,
  676. idx : integer;
  677. begin
  678. if crc_only then
  679. exit;
  680. p:=pchar(@b);
  681. idx:=0;
  682. while len>0 do
  683. begin
  684. left:=bufsize-bufidx;
  685. if len>left then
  686. begin
  687. move(p[idx],buf[bufidx],left);
  688. dec(len,left);
  689. inc(idx,left);
  690. inc(bufidx,left);
  691. writebuf;
  692. end
  693. else
  694. begin
  695. move(p[idx],buf[bufidx],len);
  696. inc(bufidx,len);
  697. exit;
  698. end;
  699. end;
  700. end;
  701. procedure tppufile.NewEntry;
  702. begin
  703. with entry do
  704. begin
  705. id:=entrytyp;
  706. nr:=ibend;
  707. size:=0;
  708. end;
  709. {Reset Entry State}
  710. entryidx:=0;
  711. entrybufstart:=bufstart;
  712. entrystart:=bufstart+bufidx;
  713. {Alloc in buffer}
  714. writedata(entry,sizeof(tppuentry));
  715. end;
  716. procedure tppufile.writeentry(ibnr:byte);
  717. var
  718. opos : integer;
  719. begin
  720. {create entry}
  721. entry.id:=entrytyp;
  722. entry.nr:=ibnr;
  723. entry.size:=entryidx;
  724. {it's already been sent to disk ?}
  725. if entrybufstart<>bufstart then
  726. begin
  727. if not crc_only then
  728. begin
  729. {flush to be sure}
  730. WriteBuf;
  731. {write entry}
  732. opos:=filepos(f);
  733. seek(f,entrystart);
  734. blockwrite(f,entry,sizeof(tppuentry));
  735. seek(f,opos);
  736. end;
  737. entrybufstart:=bufstart;
  738. end
  739. else
  740. move(entry,buf[entrystart-bufstart],sizeof(entry));
  741. {Add New Entry, which is ibend by default}
  742. entrystart:=bufstart+bufidx; {next entry position}
  743. NewEntry;
  744. end;
  745. procedure tppufile.putdata(const b;len:integer);
  746. begin
  747. if do_crc then
  748. begin
  749. crc:=UpdateCrc32(crc,b,len);
  750. {$ifdef Test_Double_checksum}
  751. if crc_only then
  752. begin
  753. crc_test2^[crc_index2]:=crc;
  754. {$ifdef Test_Double_checksum_write}
  755. Writeln(CRCFile,crc);
  756. {$endif Test_Double_checksum_write}
  757. if crc_index2<crc_array_size then
  758. inc(crc_index2);
  759. end
  760. else
  761. begin
  762. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  763. (crc_test2^[crcindex2]<>crc) then
  764. Do_comment(V_Warning,'impl CRC changed');
  765. {$ifdef Test_Double_checksum_write}
  766. Writeln(CRCFile,crc);
  767. {$endif Test_Double_checksum_write}
  768. inc(crcindex2);
  769. end;
  770. {$endif def Test_Double_checksum}
  771. if do_interface_crc then
  772. begin
  773. interface_crc:=UpdateCrc32(interface_crc,b,len);
  774. {$ifdef Test_Double_checksum}
  775. if crc_only then
  776. begin
  777. crc_test^[crc_index]:=interface_crc;
  778. {$ifdef Test_Double_checksum_write}
  779. Writeln(CRCFile,interface_crc);
  780. {$endif Test_Double_checksum_write}
  781. if crc_index<crc_array_size then
  782. inc(crc_index);
  783. end
  784. else
  785. begin
  786. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  787. (crc_test^[crcindex]<>interface_crc) then
  788. Do_comment(V_Warning,'CRC changed');
  789. {$ifdef Test_Double_checksum_write}
  790. Writeln(CRCFile,interface_crc);
  791. {$endif Test_Double_checksum_write}
  792. inc(crcindex);
  793. end;
  794. {$endif def Test_Double_checksum}
  795. end;
  796. end;
  797. if not crc_only then
  798. writedata(b,len);
  799. inc(entryidx,len);
  800. end;
  801. procedure tppufile.putbyte(b:byte);
  802. begin
  803. putdata(b,1);
  804. end;
  805. procedure tppufile.putword(w:word);
  806. begin
  807. putdata(w,2);
  808. end;
  809. procedure tppufile.putlongint(l:longint);
  810. begin
  811. putdata(l,4);
  812. end;
  813. procedure tppufile.putreal(d:ppureal);
  814. begin
  815. putdata(d,sizeof(ppureal));
  816. end;
  817. procedure tppufile.putstring(s:string);
  818. begin
  819. putdata(s,length(s)+1);
  820. end;
  821. procedure tppufile.putsmallset(const b);
  822. var
  823. l : longint;
  824. begin
  825. l:=longint(b);
  826. putlongint(l);
  827. end;
  828. procedure tppufile.putnormalset(const b);
  829. type
  830. SetLongintArray = Array [0..7] of longint;
  831. var
  832. i : longint;
  833. tempb : setlongintarray;
  834. begin
  835. if change_endian then
  836. begin
  837. for i:=0 to 7 do
  838. tempb[i]:=SwapLong(SetLongintArray(b)[i]);
  839. putdata(tempb,32);
  840. end
  841. else
  842. putdata(b,32);
  843. end;
  844. procedure tppufile.tempclose;
  845. begin
  846. if not closed then
  847. begin
  848. closepos:=filepos(f);
  849. {$I-}
  850. system.close(f);
  851. {$I+}
  852. if ioresult<>0 then;
  853. closed:=true;
  854. tempclosed:=true;
  855. end;
  856. end;
  857. function tppufile.tempopen:boolean;
  858. var
  859. ofm : byte;
  860. begin
  861. tempopen:=false;
  862. if not closed or not tempclosed then
  863. exit;
  864. ofm:=filemode;
  865. filemode:=0;
  866. {$I-}
  867. reset(f,1);
  868. {$I+}
  869. filemode:=ofm;
  870. if ioresult<>0 then
  871. exit;
  872. closed:=false;
  873. tempclosed:=false;
  874. { restore state }
  875. seek(f,closepos);
  876. tempopen:=true;
  877. end;
  878. end.
  879. {
  880. $Log$
  881. Revision 1.11 2001-06-27 21:37:36 peter
  882. * v10 merges
  883. Revision 1.10 2001/06/18 20:36:25 peter
  884. * -Ur switch (merged)
  885. * masm fixes (merged)
  886. * quoted filenames for go32v2 and win32
  887. Revision 1.9 2001/05/18 22:28:59 peter
  888. * endian define
  889. Revision 1.8 2001/05/06 14:49:17 peter
  890. * ppu object to class rewrite
  891. * move ppu read and write stuff to fppu
  892. Revision 1.7 2001/03/22 00:10:58 florian
  893. + basic variant type support in the compiler
  894. Revision 1.6 2000/12/07 17:19:43 jonas
  895. * new constant handling: from now on, hex constants >$7fffffff are
  896. parsed as unsigned constants (otherwise, $80000000 got sign extended
  897. and became $ffffffff80000000), all constants in the longint range
  898. become longints, all constants >$7fffffff and <=cardinal($ffffffff)
  899. are cardinals and the rest are int64's.
  900. * added lots of longint typecast to prevent range check errors in the
  901. compiler and rtl
  902. * type casts of symbolic ordinal constants are now preserved
  903. * fixed bug where the original resulttype wasn't restored correctly
  904. after doing a 64bit rangecheck
  905. Revision 1.5 2000/10/31 22:02:50 peter
  906. * symtable splitted, no real code changes
  907. Revision 1.4 2000/09/24 15:06:24 peter
  908. * use defines.inc
  909. Revision 1.3 2000/08/13 13:04:38 peter
  910. * new ppu version
  911. Revision 1.2 2000/07/13 11:32:45 michael
  912. + removed logs
  913. }