ppu.pas 22 KB

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