ppu.pas 22 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081
  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. {$ifdef TP}
  19. {$N+,E+}
  20. {$endif}
  21. unit ppu;
  22. interface
  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. {$define ORDERSOURCES}
  27. {$ifdef Test_Double_checksum}
  28. var
  29. CRCFile : text;
  30. const
  31. CRC_array_Size = 200000;
  32. type
  33. tcrc_array = array[0..crc_array_size] of longint;
  34. pcrc_array = ^tcrc_array;
  35. {$endif Test_Double_checksum}
  36. const
  37. {$ifdef newcg}
  38. {$ifdef ORDERSOURCES}
  39. CurrentPPUVersion=101;
  40. {$else ORDERSOURCES}
  41. CurrentPPUVersion=100;
  42. {$endif ORDERSOURCES}
  43. {$else newcg}
  44. {$ifdef ORDERSOURCES}
  45. CurrentPPUVersion=19;
  46. {$else ORDERSOURCES}
  47. CurrentPPUVersion=18;
  48. {$endif ORDERSOURCES}
  49. {$endif newcg}
  50. { buffer sizes }
  51. maxentrysize = 1024;
  52. {$ifdef TP}
  53. ppubufsize = 1024;
  54. {$else}
  55. ppubufsize = 16384;
  56. {$endif}
  57. {ppu entries}
  58. mainentryid = 1;
  59. subentryid = 2;
  60. {special}
  61. iberror = 0;
  62. ibstartdefs = 248;
  63. ibenddefs = 249;
  64. ibstartsyms = 250;
  65. ibendsyms = 251;
  66. ibendinterface = 252;
  67. ibendimplementation = 253;
  68. ibendbrowser = 254;
  69. ibend = 255;
  70. {general}
  71. ibmodulename = 1;
  72. ibsourcefiles = 2;
  73. ibloadunit = 3;
  74. ibinitunit = 4;
  75. iblinkunitofiles = 5;
  76. iblinkunitstaticlibs = 6;
  77. iblinkunitsharedlibs = 7;
  78. iblinkotherofiles = 8;
  79. iblinkotherstaticlibs = 9;
  80. iblinkothersharedlibs = 10;
  81. ibdbxcount = 11;
  82. ibsymref = 12;
  83. ibdefref = 13;
  84. ibendsymtablebrowser = 14;
  85. ibbeginsymtablebrowser = 15;
  86. ibusedmacros = 16;
  87. {syms}
  88. ibtypesym = 20;
  89. ibprocsym = 21;
  90. ibvarsym = 22;
  91. ibconstsym = 23;
  92. ibenumsym = 24;
  93. ibtypedconstsym = 25;
  94. ibabsolutesym = 26;
  95. ibpropertysym = 27;
  96. ibvarsym_C = 28;
  97. ibunitsym = 29; { needed for browser }
  98. iblabelsym = 30;
  99. ibfuncretsym = 31;
  100. ibsyssym = 32;
  101. {definitions}
  102. iborddef = 40;
  103. ibpointerdef = 41;
  104. ibarraydef = 42;
  105. ibprocdef = 43;
  106. ibshortstringdef = 44;
  107. ibrecorddef = 45;
  108. ibfiledef = 46;
  109. ibformaldef = 47;
  110. ibobjectdef = 48;
  111. ibenumdef = 49;
  112. ibsetdef = 50;
  113. ibprocvardef = 51;
  114. ibfloatdef = 52;
  115. ibclassrefdef = 53;
  116. iblongstringdef = 54;
  117. ibansistringdef = 55;
  118. ibwidestringdef = 56;
  119. { unit flags }
  120. uf_init = $1;
  121. uf_finalize = $2;
  122. uf_big_endian = $4;
  123. uf_has_dbx = $8;
  124. uf_has_browser = $10;
  125. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  126. uf_smart_linked = $40; { the ppu can be smartlinked }
  127. uf_static_linked = $80; { the ppu can be linked static }
  128. uf_shared_linked = $100; { the ppu can be linked shared }
  129. uf_local_browser = $200;
  130. uf_no_link = $400; { unit has no .o generated, but can still have
  131. external linking! }
  132. uf_has_resources = $800; { unit has resource section }
  133. type
  134. {$ifdef m68k}
  135. ppureal=single;
  136. {$else}
  137. ppureal=extended;
  138. {$endif}
  139. tppuerror=(ppuentrytoobig,ppuentryerror);
  140. tppuheader=packed record { 40 bytes }
  141. id : array[1..3] of char; { = 'PPU' }
  142. ver : array[1..3] of char;
  143. compiler : word;
  144. cpu : word;
  145. target : word;
  146. flags : longint;
  147. size : longint; { size of the ppufile without header }
  148. checksum : longint; { checksum for this ppufile }
  149. interface_checksum : longint;
  150. future : array[0..2] of longint;
  151. end;
  152. tppuentry=packed record
  153. id : byte;
  154. nr : byte;
  155. size : longint;
  156. end;
  157. pppufile=^tppufile;
  158. tppufile=object
  159. f : file;
  160. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  161. error : boolean;
  162. fname : string;
  163. fsize : longint;
  164. header : tppuheader;
  165. size,crc : longint;
  166. {$ifdef Test_Double_checksum}
  167. crcindex : longint;
  168. crc_index : longint;
  169. crcindex2 : longint;
  170. crc_index2 : longint;
  171. crc_test,crc_test2 : pcrc_array;
  172. {$endif def Test_Double_checksum}
  173. interface_crc : longint;
  174. do_interface_crc : boolean;
  175. crc_only : boolean; { used to calculate interface_crc before implementation }
  176. do_crc,
  177. change_endian : boolean;
  178. buf : pchar;
  179. bufstart,
  180. bufsize,
  181. bufidx : longint;
  182. entrybufstart,
  183. entrystart,
  184. entryidx : longint;
  185. entry : tppuentry;
  186. entrytyp : byte;
  187. closed,
  188. tempclosed : boolean;
  189. closepos : longint;
  190. constructor init(fn:string);
  191. destructor done;
  192. procedure flush;
  193. procedure close;
  194. function CheckPPUId:boolean;
  195. function GetPPUVersion:longint;
  196. procedure NewHeader;
  197. procedure NewEntry;
  198. {read}
  199. function open:boolean;
  200. procedure reloadbuf;
  201. procedure readdata(var b;len:longint);
  202. procedure skipdata(len:longint);
  203. function readentry:byte;
  204. function EndOfEntry:boolean;
  205. procedure getdatabuf(var b;len:longint;var result:longint);
  206. procedure getdata(var b;len:longint);
  207. function getbyte:byte;
  208. function getword:word;
  209. function getlongint:longint;
  210. function getreal:ppureal;
  211. function getstring:string;
  212. procedure getnormalset(var b);
  213. procedure getsmallset(var b);
  214. function skipuntilentry(untilb:byte):boolean;
  215. {write}
  216. function create:boolean;
  217. procedure writeheader;
  218. procedure writebuf;
  219. procedure writedata(var b;len:longint);
  220. procedure writeentry(ibnr:byte);
  221. procedure putdata(var b;len:longint);
  222. procedure putbyte(b:byte);
  223. procedure putword(w:word);
  224. procedure putlongint(l:longint);
  225. procedure putreal(d:ppureal);
  226. procedure putstring(s:string);
  227. procedure putnormalset(var b);
  228. procedure putsmallset(var b);
  229. procedure tempclose;
  230. function tempopen:boolean;
  231. end;
  232. implementation
  233. {$ifdef Test_Double_checksum}
  234. uses
  235. comphook;
  236. {$endif def Test_Double_checksum}
  237. {*****************************************************************************
  238. Crc 32
  239. *****************************************************************************}
  240. var
  241. {$ifdef Delphi}
  242. Crc32Tbl : array[0..255] of longword;
  243. {$else Delphi}
  244. Crc32Tbl : array[0..255] of longint;
  245. {$endif Delphi}
  246. procedure MakeCRC32Tbl;
  247. var
  248. {$ifdef Delphi}
  249. crc : longword;
  250. {$else Delphi}
  251. crc : longint;
  252. {$endif Delphi}
  253. i,n : byte;
  254. begin
  255. for i:=0 to 255 do
  256. begin
  257. crc:=i;
  258. for n:=1 to 8 do
  259. if odd(crc) then
  260. crc:=(crc shr 1) xor $edb88320
  261. else
  262. crc:=crc shr 1;
  263. Crc32Tbl[i]:=crc;
  264. end;
  265. end;
  266. {$ifopt R+}
  267. {$define Range_check_on}
  268. {$endif opt R+}
  269. {$R- needed here }
  270. {CRC 32}
  271. Function Crc32(Const HStr:String):longint;
  272. var
  273. i,InitCrc : longint;
  274. begin
  275. if Crc32Tbl[1]=0 then
  276. MakeCrc32Tbl;
  277. InitCrc:=$ffffffff;
  278. for i:=1to Length(Hstr) do
  279. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
  280. Crc32:=InitCrc;
  281. end;
  282. Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
  283. var
  284. i : word;
  285. p : pchar;
  286. begin
  287. if Crc32Tbl[1]=0 then
  288. MakeCrc32Tbl;
  289. p:=@InBuf;
  290. for i:=1 to InLen do
  291. begin
  292. InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
  293. inc(longint(p));
  294. end;
  295. UpdateCrc32:=InitCrc;
  296. end;
  297. Function UpdCrc32(InitCrc:longint;b:byte):longint;
  298. begin
  299. if Crc32Tbl[1]=0 then
  300. MakeCrc32Tbl;
  301. UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
  302. end;
  303. {$ifdef Range_check_on}
  304. {$R+}
  305. {$undef Range_check_on}
  306. {$endif Range_check_on}
  307. {*****************************************************************************
  308. TPPUFile
  309. *****************************************************************************}
  310. constructor tppufile.init(fn:string);
  311. begin
  312. fname:=fn;
  313. change_endian:=false;
  314. crc_only:=false;
  315. Mode:=0;
  316. NewHeader;
  317. Error:=false;
  318. closed:=true;
  319. tempclosed:=false;
  320. getmem(buf,ppubufsize);
  321. end;
  322. destructor tppufile.done;
  323. begin
  324. close;
  325. if assigned(buf) then
  326. freemem(buf,ppubufsize);
  327. end;
  328. procedure tppufile.flush;
  329. begin
  330. if Mode=2 then
  331. writebuf;
  332. end;
  333. procedure tppufile.close;
  334. begin
  335. if Mode<>0 then
  336. begin
  337. Flush;
  338. {$I-}
  339. system.close(f);
  340. {$I+}
  341. if ioresult<>0 then;
  342. Mode:=0;
  343. closed:=true;
  344. end;
  345. end;
  346. function tppufile.CheckPPUId:boolean;
  347. begin
  348. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  349. end;
  350. function tppufile.GetPPUVersion:longint;
  351. var
  352. l : longint;
  353. code : integer;
  354. begin
  355. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  356. if code=0 then
  357. GetPPUVersion:=l
  358. else
  359. GetPPUVersion:=0;
  360. end;
  361. procedure tppufile.NewHeader;
  362. var
  363. s : string;
  364. begin
  365. fillchar(header,sizeof(tppuheader),0);
  366. str(currentppuversion,s);
  367. while length(s)<3 do
  368. s:='0'+s;
  369. with header do
  370. begin
  371. Id[1]:='P';
  372. Id[2]:='P';
  373. Id[3]:='U';
  374. Ver[1]:=s[1];
  375. Ver[2]:=s[2];
  376. Ver[3]:=s[3];
  377. end;
  378. end;
  379. {*****************************************************************************
  380. TPPUFile Reading
  381. *****************************************************************************}
  382. function tppufile.open:boolean;
  383. var
  384. ofmode : byte;
  385. {$ifdef delphi}
  386. i : integer;
  387. {$else delphi}
  388. i : word;
  389. {$endif delphi}
  390. begin
  391. open:=false;
  392. assign(f,fname);
  393. ofmode:=filemode;
  394. filemode:=$0;
  395. {$I-}
  396. reset(f,1);
  397. {$I+}
  398. filemode:=ofmode;
  399. if ioresult<>0 then
  400. exit;
  401. closed:=false;
  402. {read ppuheader}
  403. fsize:=filesize(f);
  404. if fsize<sizeof(tppuheader) then
  405. exit;
  406. blockread(f,header,sizeof(tppuheader),i);
  407. {reset buffer}
  408. bufstart:=i;
  409. bufsize:=0;
  410. bufidx:=0;
  411. Mode:=1;
  412. FillChar(entry,sizeof(tppuentry),0);
  413. entryidx:=0;
  414. entrystart:=0;
  415. entrybufstart:=0;
  416. Error:=false;
  417. open:=true;
  418. end;
  419. procedure tppufile.reloadbuf;
  420. {$ifdef TP}
  421. var
  422. i : word;
  423. {$endif}
  424. begin
  425. inc(bufstart,bufsize);
  426. {$ifdef TP}
  427. blockread(f,buf^,ppubufsize,i);
  428. bufsize:=i;
  429. {$else}
  430. blockread(f,buf^,ppubufsize,bufsize);
  431. {$endif}
  432. bufidx:=0;
  433. end;
  434. procedure tppufile.readdata(var b;len:longint);
  435. var
  436. p : pchar;
  437. left,
  438. idx : longint;
  439. begin
  440. p:=pchar(@b);
  441. idx:=0;
  442. while len>0 do
  443. begin
  444. left:=bufsize-bufidx;
  445. if len>left then
  446. begin
  447. move(buf[bufidx],p[idx],left);
  448. dec(len,left);
  449. inc(idx,left);
  450. reloadbuf;
  451. if bufsize=0 then
  452. exit;
  453. end
  454. else
  455. begin
  456. move(buf[bufidx],p[idx],len);
  457. inc(bufidx,len);
  458. exit;
  459. end;
  460. end;
  461. end;
  462. procedure tppufile.skipdata(len:longint);
  463. var
  464. left : longint;
  465. begin
  466. while len>0 do
  467. begin
  468. left:=bufsize-bufidx;
  469. if len>left then
  470. begin
  471. dec(len,left);
  472. reloadbuf;
  473. if bufsize=0 then
  474. exit;
  475. end
  476. else
  477. begin
  478. inc(bufidx,len);
  479. exit;
  480. end;
  481. end;
  482. end;
  483. function tppufile.readentry:byte;
  484. begin
  485. if entryidx<entry.size then
  486. skipdata(entry.size-entryidx);
  487. readdata(entry,sizeof(tppuentry));
  488. entrystart:=bufstart+bufidx;
  489. entryidx:=0;
  490. if not(entry.id in [mainentryid,subentryid]) then
  491. begin
  492. readentry:=iberror;
  493. error:=true;
  494. exit;
  495. end;
  496. readentry:=entry.nr;
  497. end;
  498. function tppufile.endofentry:boolean;
  499. begin
  500. endofentry:=(entryidx>=entry.size);
  501. end;
  502. procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
  503. begin
  504. if entryidx+len>entry.size then
  505. result:=entry.size-entryidx
  506. else
  507. result:=len;
  508. readdata(b,result);
  509. inc(entryidx,result);
  510. end;
  511. procedure tppufile.getdata(var b;len:longint);
  512. begin
  513. if entryidx+len>entry.size then
  514. begin
  515. error:=true;
  516. exit;
  517. end;
  518. readdata(b,len);
  519. inc(entryidx,len);
  520. end;
  521. function tppufile.getbyte:byte;
  522. var
  523. b : byte;
  524. begin
  525. if entryidx+1>entry.size then
  526. begin
  527. error:=true;
  528. getbyte:=0;
  529. exit;
  530. end;
  531. readdata(b,1);
  532. getbyte:=b;
  533. inc(entryidx);
  534. end;
  535. function tppufile.getword:word;
  536. type
  537. pword = ^word;
  538. var
  539. w : word;
  540. begin
  541. if entryidx+2>entry.size then
  542. begin
  543. error:=true;
  544. getword:=0;
  545. exit;
  546. end;
  547. readdata(w,2);
  548. if change_endian then
  549. getword:=swap(w)
  550. else
  551. getword:=w;
  552. inc(entryidx,2);
  553. end;
  554. function tppufile.getlongint:longint;
  555. type
  556. plongint = ^longint;
  557. var
  558. l : longint;
  559. begin
  560. if entryidx+4>entry.size then
  561. begin
  562. error:=true;
  563. getlongint:=0;
  564. exit;
  565. end;
  566. readdata(l,4);
  567. if change_endian then
  568. { someone added swap(l : longint) in system unit
  569. this broke the following code !! }
  570. getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
  571. else
  572. getlongint:=l;
  573. inc(entryidx,4);
  574. end;
  575. function tppufile.getreal:ppureal;
  576. type
  577. pppureal = ^ppureal;
  578. var
  579. d : ppureal;
  580. begin
  581. if entryidx+sizeof(ppureal)>entry.size then
  582. begin
  583. error:=true;
  584. getreal:=0;
  585. exit;
  586. end;
  587. readdata(d,sizeof(ppureal));
  588. getreal:=d;
  589. inc(entryidx,sizeof(ppureal));
  590. end;
  591. function tppufile.getstring:string;
  592. var
  593. s : string;
  594. begin
  595. {$ifndef TP}
  596. {$ifopt H+}
  597. setlength(s,getbyte);
  598. {$else}
  599. s[0]:=chr(getbyte);
  600. {$endif}
  601. {$else}
  602. s[0]:=chr(getbyte);
  603. {$endif}
  604. if entryidx+length(s)>entry.size then
  605. begin
  606. error:=true;
  607. exit;
  608. end;
  609. ReadData(s[1],length(s));
  610. getstring:=s;
  611. inc(entryidx,length(s));
  612. end;
  613. procedure tppufile.getsmallset(var b);
  614. begin
  615. getdata(b,4);
  616. end;
  617. procedure tppufile.getnormalset(var b);
  618. begin
  619. getdata(b,32);
  620. end;
  621. function tppufile.skipuntilentry(untilb:byte):boolean;
  622. var
  623. b : byte;
  624. begin
  625. repeat
  626. b:=readentry;
  627. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  628. skipuntilentry:=(b=untilb);
  629. end;
  630. {*****************************************************************************
  631. TPPUFile Writing
  632. *****************************************************************************}
  633. function tppufile.create:boolean;
  634. begin
  635. create:=false;
  636. {$ifdef INTFPPU}
  637. if crc_only then
  638. begin
  639. fname:=fname+'.intf';
  640. crc_only:=false;
  641. end;
  642. {$endif}
  643. if not crc_only then
  644. begin
  645. assign(f,fname);
  646. {$I-}
  647. rewrite(f,1);
  648. {$I+}
  649. if ioresult<>0 then
  650. exit;
  651. Mode:=2;
  652. {write header for sure}
  653. blockwrite(f,header,sizeof(tppuheader));
  654. end;
  655. bufsize:=ppubufsize;
  656. bufstart:=sizeof(tppuheader);
  657. bufidx:=0;
  658. {reset}
  659. crc:=$ffffffff;
  660. interface_crc:=$ffffffff;
  661. do_interface_crc:=true;
  662. Error:=false;
  663. do_crc:=true;
  664. size:=0;
  665. entrytyp:=mainentryid;
  666. {start}
  667. NewEntry;
  668. create:=true;
  669. end;
  670. procedure tppufile.writeheader;
  671. var
  672. opos : longint;
  673. begin
  674. { flush buffer }
  675. writebuf;
  676. { update size (w/o header!) in the header }
  677. header.size:=bufstart-sizeof(tppuheader);
  678. { write header and restore filepos after it }
  679. opos:=filepos(f);
  680. seek(f,0);
  681. blockwrite(f,header,sizeof(tppuheader));
  682. seek(f,opos);
  683. end;
  684. procedure tppufile.writebuf;
  685. begin
  686. if not crc_only then
  687. blockwrite(f,buf^,bufidx);
  688. inc(bufstart,bufidx);
  689. bufidx:=0;
  690. end;
  691. procedure tppufile.writedata(var b;len:longint);
  692. var
  693. p : pchar;
  694. left,
  695. idx : longint;
  696. begin
  697. if crc_only then
  698. exit;
  699. p:=pchar(@b);
  700. idx:=0;
  701. while len>0 do
  702. begin
  703. left:=bufsize-bufidx;
  704. if len>left then
  705. begin
  706. move(p[idx],buf[bufidx],left);
  707. dec(len,left);
  708. inc(idx,left);
  709. inc(bufidx,left);
  710. writebuf;
  711. end
  712. else
  713. begin
  714. move(p[idx],buf[bufidx],len);
  715. inc(bufidx,len);
  716. exit;
  717. end;
  718. end;
  719. end;
  720. procedure tppufile.NewEntry;
  721. begin
  722. with entry do
  723. begin
  724. id:=entrytyp;
  725. nr:=ibend;
  726. size:=0;
  727. end;
  728. {Reset Entry State}
  729. entryidx:=0;
  730. entrybufstart:=bufstart;
  731. entrystart:=bufstart+bufidx;
  732. {Alloc in buffer}
  733. writedata(entry,sizeof(tppuentry));
  734. end;
  735. procedure tppufile.writeentry(ibnr:byte);
  736. var
  737. opos : longint;
  738. begin
  739. {create entry}
  740. entry.id:=entrytyp;
  741. entry.nr:=ibnr;
  742. entry.size:=entryidx;
  743. {it's already been sent to disk ?}
  744. if entrybufstart<>bufstart then
  745. begin
  746. if not crc_only then
  747. begin
  748. {flush to be sure}
  749. WriteBuf;
  750. {write entry}
  751. opos:=filepos(f);
  752. seek(f,entrystart);
  753. blockwrite(f,entry,sizeof(tppuentry));
  754. seek(f,opos);
  755. end;
  756. entrybufstart:=bufstart;
  757. end
  758. else
  759. move(entry,buf[entrystart-bufstart],sizeof(entry));
  760. {Add New Entry, which is ibend by default}
  761. entrystart:=bufstart+bufidx; {next entry position}
  762. NewEntry;
  763. end;
  764. procedure tppufile.putdata(var b;len:longint);
  765. begin
  766. if do_crc then
  767. begin
  768. crc:=UpdateCrc32(crc,b,len);
  769. {$ifdef Test_Double_checksum}
  770. if crc_only then
  771. begin
  772. crc_test2^[crc_index2]:=crc;
  773. {$ifdef Test_Double_checksum_write}
  774. Writeln(CRCFile,crc);
  775. {$endif Test_Double_checksum_write}
  776. if crc_index2<crc_array_size then
  777. inc(crc_index2);
  778. end
  779. else
  780. begin
  781. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  782. (crc_test2^[crcindex2]<>crc) then
  783. Do_comment(V_Warning,'impl CRC changed');
  784. {$ifdef Test_Double_checksum_write}
  785. Writeln(CRCFile,crc);
  786. {$endif Test_Double_checksum_write}
  787. inc(crcindex2);
  788. end;
  789. {$endif def Test_Double_checksum}
  790. if do_interface_crc then
  791. begin
  792. interface_crc:=UpdateCrc32(interface_crc,b,len);
  793. {$ifdef Test_Double_checksum}
  794. if crc_only then
  795. begin
  796. crc_test^[crc_index]:=interface_crc;
  797. {$ifdef Test_Double_checksum_write}
  798. Writeln(CRCFile,interface_crc);
  799. {$endif Test_Double_checksum_write}
  800. if crc_index<crc_array_size then
  801. inc(crc_index);
  802. end
  803. else
  804. begin
  805. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  806. (crc_test^[crcindex]<>interface_crc) then
  807. Do_comment(V_Warning,'CRC changed');
  808. {$ifdef Test_Double_checksum_write}
  809. Writeln(CRCFile,interface_crc);
  810. {$endif Test_Double_checksum_write}
  811. inc(crcindex);
  812. end;
  813. {$endif def Test_Double_checksum}
  814. end;
  815. end;
  816. if not crc_only then
  817. writedata(b,len);
  818. inc(entryidx,len);
  819. end;
  820. procedure tppufile.putbyte(b:byte);
  821. begin
  822. putdata(b,1);
  823. { inc(entryidx);}
  824. end;
  825. procedure tppufile.putword(w:word);
  826. begin
  827. if change_endian then
  828. w:=swap(w);
  829. putdata(w,2);
  830. end;
  831. procedure tppufile.putlongint(l:longint);
  832. begin
  833. if change_endian then
  834. { someone added swap(l : longint) in system unit
  835. this broke the following code !! }
  836. l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
  837. putdata(l,4);
  838. end;
  839. procedure tppufile.putreal(d:ppureal);
  840. begin
  841. putdata(d,sizeof(ppureal));
  842. end;
  843. procedure tppufile.putstring(s:string);
  844. begin
  845. putdata(s,length(s)+1);
  846. end;
  847. procedure tppufile.putsmallset(var b);
  848. begin
  849. putdata(b,4);
  850. end;
  851. procedure tppufile.putnormalset(var b);
  852. begin
  853. putdata(b,32);
  854. end;
  855. procedure tppufile.tempclose;
  856. begin
  857. if not closed then
  858. begin
  859. closepos:=filepos(f);
  860. {$I-}
  861. system.close(f);
  862. {$I+}
  863. if ioresult<>0 then;
  864. closed:=true;
  865. tempclosed:=true;
  866. end;
  867. end;
  868. function tppufile.tempopen:boolean;
  869. var
  870. ofm : byte;
  871. begin
  872. tempopen:=false;
  873. if not closed or not tempclosed then
  874. exit;
  875. ofm:=filemode;
  876. filemode:=0;
  877. {$I-}
  878. reset(f,1);
  879. {$I+}
  880. filemode:=ofm;
  881. if ioresult<>0 then
  882. exit;
  883. closed:=false;
  884. tempclosed:=false;
  885. { restore state }
  886. seek(f,closepos);
  887. tempopen:=true;
  888. end;
  889. end.
  890. {
  891. $Log$
  892. Revision 1.56 2000-02-29 21:58:31 pierre
  893. * ORDERSOURCES released
  894. Revision 1.55 2000/02/09 13:22:59 peter
  895. * log truncated
  896. Revision 1.54 2000/01/07 01:14:30 peter
  897. * updated copyright to 2000
  898. Revision 1.53 1999/12/02 11:29:07 peter
  899. * INFTPPU define to write the ppu of the interface to .ppu.intf
  900. Revision 1.52 1999/11/30 10:40:45 peter
  901. + ttype, tsymlist
  902. Revision 1.51 1999/11/23 09:42:38 peter
  903. * makefile updates to work with new fpcmake
  904. Revision 1.50 1999/11/21 01:42:37 pierre
  905. * Nextoverloading ordering fix
  906. Revision 1.49 1999/11/18 15:34:48 pierre
  907. * Notes/Hints for local syms changed to
  908. Set_varstate function
  909. Revision 1.48 1999/11/17 17:05:02 pierre
  910. * Notes/hints changes
  911. Revision 1.47 1999/11/06 14:34:23 peter
  912. * truncated log to 20 revs
  913. Revision 1.46 1999/09/17 09:14:56 peter
  914. * ppu header writting now uses currentppuversion
  915. Revision 1.45 1999/09/16 13:27:08 pierre
  916. + error if PPU modulename is different from what is searched
  917. (8+3 limitations!)
  918. + cond ORDERSOURCES to allow recompilation of FP
  919. if symppu.inc is changed (need PPUversion change!)
  920. Revision 1.44 1999/09/16 11:34:58 pierre
  921. * typo correction
  922. Revision 1.43 1999/09/10 18:48:09 florian
  923. * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
  924. * most things for stored properties fixed
  925. Revision 1.42 1999/08/31 15:47:56 pierre
  926. + startup conditionals stored in PPU file for debug info
  927. Revision 1.41 1999/08/30 16:21:40 pierre
  928. * tempclosing of ppufiles under dos was wrong
  929. Revision 1.40 1999/08/27 10:48:40 pierre
  930. + tppufile.tempclose and tempopen added
  931. * some changes so that nothing is writtedn to disk while
  932. calculating CRC only
  933. Revision 1.39 1999/08/24 12:01:36 michael
  934. + changes for resourcestrings
  935. Revision 1.38 1999/08/15 10:47:48 peter
  936. + normalset,smallset writing
  937. Revision 1.37 1999/08/02 23:13:20 florian
  938. * more changes to compile for the Alpha
  939. Revision 1.36 1999/07/23 16:05:25 peter
  940. * alignment is now saved in the symtable
  941. * C alignment added for records
  942. * PPU version increased to solve .12 <-> .13 probs
  943. }