ppu.pas 23 KB

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