ppu.pas 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080
  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=18;
  42. {$else ORDERSOURCES}
  43. CurrentPPUVersion=17;
  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:=1to 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. var
  331. i : word;
  332. begin
  333. if Mode<>0 then
  334. begin
  335. Flush;
  336. {$I-}
  337. system.close(f);
  338. {$I+}
  339. i:=ioresult;
  340. Mode:=0;
  341. closed:=true;
  342. end;
  343. end;
  344. function tppufile.CheckPPUId:boolean;
  345. begin
  346. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  347. end;
  348. function tppufile.GetPPUVersion:longint;
  349. var
  350. l : longint;
  351. code : integer;
  352. begin
  353. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  354. if code=0 then
  355. GetPPUVersion:=l
  356. else
  357. GetPPUVersion:=0;
  358. end;
  359. procedure tppufile.NewHeader;
  360. var
  361. s : string;
  362. begin
  363. fillchar(header,sizeof(tppuheader),0);
  364. str(currentppuversion,s);
  365. while length(s)<3 do
  366. s:='0'+s;
  367. with header do
  368. begin
  369. Id[1]:='P';
  370. Id[2]:='P';
  371. Id[3]:='U';
  372. Ver[1]:=s[1];
  373. Ver[2]:=s[2];
  374. Ver[3]:=s[3];
  375. end;
  376. end;
  377. {*****************************************************************************
  378. TPPUFile Reading
  379. *****************************************************************************}
  380. function tppufile.open:boolean;
  381. var
  382. ofmode : byte;
  383. {$ifdef delphi}
  384. i : integer;
  385. {$else delphi}
  386. i : word;
  387. {$endif delphi}
  388. begin
  389. open:=false;
  390. assign(f,fname);
  391. ofmode:=filemode;
  392. filemode:=$0;
  393. {$I-}
  394. reset(f,1);
  395. {$I+}
  396. filemode:=ofmode;
  397. if ioresult<>0 then
  398. exit;
  399. closed:=false;
  400. {read ppuheader}
  401. fsize:=filesize(f);
  402. if fsize<sizeof(tppuheader) then
  403. exit;
  404. blockread(f,header,sizeof(tppuheader),i);
  405. {reset buffer}
  406. bufstart:=i;
  407. bufsize:=0;
  408. bufidx:=0;
  409. Mode:=1;
  410. FillChar(entry,sizeof(tppuentry),0);
  411. entryidx:=0;
  412. entrystart:=0;
  413. entrybufstart:=0;
  414. Error:=false;
  415. open:=true;
  416. end;
  417. procedure tppufile.reloadbuf;
  418. {$ifdef TP}
  419. var
  420. i : word;
  421. {$endif}
  422. begin
  423. inc(bufstart,bufsize);
  424. {$ifdef TP}
  425. blockread(f,buf^,ppubufsize,i);
  426. bufsize:=i;
  427. {$else}
  428. blockread(f,buf^,ppubufsize,bufsize);
  429. {$endif}
  430. bufidx:=0;
  431. end;
  432. procedure tppufile.readdata(var b;len:longint);
  433. var
  434. p : pchar;
  435. left,
  436. idx : longint;
  437. begin
  438. p:=pchar(@b);
  439. idx:=0;
  440. while len>0 do
  441. begin
  442. left:=bufsize-bufidx;
  443. if len>left then
  444. begin
  445. move(buf[bufidx],p[idx],left);
  446. dec(len,left);
  447. inc(idx,left);
  448. reloadbuf;
  449. if bufsize=0 then
  450. exit;
  451. end
  452. else
  453. begin
  454. move(buf[bufidx],p[idx],len);
  455. inc(bufidx,len);
  456. exit;
  457. end;
  458. end;
  459. end;
  460. procedure tppufile.skipdata(len:longint);
  461. var
  462. left : longint;
  463. begin
  464. while len>0 do
  465. begin
  466. left:=bufsize-bufidx;
  467. if len>left then
  468. begin
  469. dec(len,left);
  470. reloadbuf;
  471. if bufsize=0 then
  472. exit;
  473. end
  474. else
  475. begin
  476. inc(bufidx,len);
  477. exit;
  478. end;
  479. end;
  480. end;
  481. function tppufile.readentry:byte;
  482. begin
  483. if entryidx<entry.size then
  484. skipdata(entry.size-entryidx);
  485. readdata(entry,sizeof(tppuentry));
  486. entrystart:=bufstart+bufidx;
  487. entryidx:=0;
  488. if not(entry.id in [mainentryid,subentryid]) then
  489. begin
  490. readentry:=iberror;
  491. error:=true;
  492. exit;
  493. end;
  494. readentry:=entry.nr;
  495. end;
  496. function tppufile.endofentry:boolean;
  497. begin
  498. endofentry:=(entryidx>=entry.size);
  499. end;
  500. procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
  501. begin
  502. if entryidx+len>entry.size then
  503. result:=entry.size-entryidx
  504. else
  505. result:=len;
  506. readdata(b,result);
  507. inc(entryidx,result);
  508. end;
  509. procedure tppufile.getdata(var b;len:longint);
  510. begin
  511. if entryidx+len>entry.size then
  512. begin
  513. error:=true;
  514. exit;
  515. end;
  516. readdata(b,len);
  517. inc(entryidx,len);
  518. end;
  519. function tppufile.getbyte:byte;
  520. var
  521. b : byte;
  522. begin
  523. if entryidx+1>entry.size then
  524. begin
  525. error:=true;
  526. getbyte:=0;
  527. exit;
  528. end;
  529. readdata(b,1);
  530. getbyte:=b;
  531. inc(entryidx);
  532. end;
  533. function tppufile.getword:word;
  534. type
  535. pword = ^word;
  536. var
  537. w : word;
  538. begin
  539. if entryidx+2>entry.size then
  540. begin
  541. error:=true;
  542. getword:=0;
  543. exit;
  544. end;
  545. readdata(w,2);
  546. if change_endian then
  547. getword:=swap(w)
  548. else
  549. getword:=w;
  550. inc(entryidx,2);
  551. end;
  552. function tppufile.getlongint:longint;
  553. type
  554. plongint = ^longint;
  555. var
  556. l : longint;
  557. begin
  558. if entryidx+4>entry.size then
  559. begin
  560. error:=true;
  561. getlongint:=0;
  562. exit;
  563. end;
  564. readdata(l,4);
  565. if change_endian then
  566. { someone added swap(l : longint) in system unit
  567. this broke the following code !! }
  568. getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
  569. else
  570. getlongint:=l;
  571. inc(entryidx,4);
  572. end;
  573. function tppufile.getreal:ppureal;
  574. type
  575. pppureal = ^ppureal;
  576. var
  577. d : ppureal;
  578. begin
  579. if entryidx+sizeof(ppureal)>entry.size then
  580. begin
  581. error:=true;
  582. getreal:=0;
  583. exit;
  584. end;
  585. readdata(d,sizeof(ppureal));
  586. getreal:=d;
  587. inc(entryidx,sizeof(ppureal));
  588. end;
  589. function tppufile.getstring:string;
  590. var
  591. s : string;
  592. begin
  593. {$ifndef TP}
  594. {$ifopt H+}
  595. setlength(s,getbyte);
  596. {$else}
  597. s[0]:=chr(getbyte);
  598. {$endif}
  599. {$else}
  600. s[0]:=chr(getbyte);
  601. {$endif}
  602. if entryidx+length(s)>entry.size then
  603. begin
  604. error:=true;
  605. exit;
  606. end;
  607. ReadData(s[1],length(s));
  608. getstring:=s;
  609. inc(entryidx,length(s));
  610. end;
  611. procedure tppufile.getsmallset(var b);
  612. begin
  613. getdata(b,4);
  614. end;
  615. procedure tppufile.getnormalset(var b);
  616. begin
  617. getdata(b,32);
  618. end;
  619. function tppufile.skipuntilentry(untilb:byte):boolean;
  620. var
  621. b : byte;
  622. begin
  623. repeat
  624. b:=readentry;
  625. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  626. skipuntilentry:=(b=untilb);
  627. end;
  628. {*****************************************************************************
  629. TPPUFile Writing
  630. *****************************************************************************}
  631. function tppufile.create:boolean;
  632. begin
  633. create:=false;
  634. if not crc_only then
  635. begin
  636. assign(f,fname);
  637. {$I-}
  638. rewrite(f,1);
  639. {$I+}
  640. if ioresult<>0 then
  641. exit;
  642. Mode:=2;
  643. {write header for sure}
  644. blockwrite(f,header,sizeof(tppuheader));
  645. end;
  646. bufsize:=ppubufsize;
  647. bufstart:=sizeof(tppuheader);
  648. bufidx:=0;
  649. {reset}
  650. crc:=$ffffffff;
  651. interface_crc:=$ffffffff;
  652. do_interface_crc:=true;
  653. Error:=false;
  654. do_crc:=true;
  655. size:=0;
  656. entrytyp:=mainentryid;
  657. {start}
  658. NewEntry;
  659. create:=true;
  660. end;
  661. procedure tppufile.writeheader;
  662. var
  663. opos : longint;
  664. begin
  665. { flush buffer }
  666. writebuf;
  667. { update size (w/o header!) in the header }
  668. header.size:=bufstart-sizeof(tppuheader);
  669. { write header and restore filepos after it }
  670. opos:=filepos(f);
  671. seek(f,0);
  672. blockwrite(f,header,sizeof(tppuheader));
  673. seek(f,opos);
  674. end;
  675. procedure tppufile.writebuf;
  676. begin
  677. if not crc_only then
  678. blockwrite(f,buf^,bufidx);
  679. inc(bufstart,bufidx);
  680. bufidx:=0;
  681. end;
  682. procedure tppufile.writedata(var b;len:longint);
  683. var
  684. p : pchar;
  685. left,
  686. idx : longint;
  687. begin
  688. if crc_only then
  689. exit;
  690. p:=pchar(@b);
  691. idx:=0;
  692. while len>0 do
  693. begin
  694. left:=bufsize-bufidx;
  695. if len>left then
  696. begin
  697. move(p[idx],buf[bufidx],left);
  698. dec(len,left);
  699. inc(idx,left);
  700. inc(bufidx,left);
  701. writebuf;
  702. end
  703. else
  704. begin
  705. move(p[idx],buf[bufidx],len);
  706. inc(bufidx,len);
  707. exit;
  708. end;
  709. end;
  710. end;
  711. procedure tppufile.NewEntry;
  712. begin
  713. with entry do
  714. begin
  715. id:=entrytyp;
  716. nr:=ibend;
  717. size:=0;
  718. end;
  719. {Reset Entry State}
  720. entryidx:=0;
  721. entrybufstart:=bufstart;
  722. entrystart:=bufstart+bufidx;
  723. {Alloc in buffer}
  724. writedata(entry,sizeof(tppuentry));
  725. end;
  726. procedure tppufile.writeentry(ibnr:byte);
  727. var
  728. opos : longint;
  729. begin
  730. {create entry}
  731. entry.id:=entrytyp;
  732. entry.nr:=ibnr;
  733. entry.size:=entryidx;
  734. {it's already been sent to disk ?}
  735. if entrybufstart<>bufstart then
  736. begin
  737. if not crc_only then
  738. begin
  739. {flush to be sure}
  740. WriteBuf;
  741. {write entry}
  742. opos:=filepos(f);
  743. seek(f,entrystart);
  744. blockwrite(f,entry,sizeof(tppuentry));
  745. seek(f,opos);
  746. end;
  747. entrybufstart:=bufstart;
  748. end
  749. else
  750. move(entry,buf[entrystart-bufstart],sizeof(entry));
  751. {Add New Entry, which is ibend by default}
  752. entrystart:=bufstart+bufidx; {next entry position}
  753. NewEntry;
  754. end;
  755. procedure tppufile.putdata(var b;len:longint);
  756. begin
  757. if do_crc then
  758. begin
  759. crc:=UpdateCrc32(crc,b,len);
  760. {$ifdef Test_Double_checksum}
  761. if crc_only then
  762. begin
  763. crc_test2^[crc_index2]:=crc;
  764. {$ifdef Test_Double_checksum_write}
  765. Writeln(CRCFile,crc);
  766. {$endif Test_Double_checksum_write}
  767. if crc_index2<crc_array_size then
  768. inc(crc_index2);
  769. end
  770. else
  771. begin
  772. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  773. (crc_test2^[crcindex2]<>crc) then
  774. Do_comment(V_Warning,'impl CRC changed');
  775. {$ifdef Test_Double_checksum_write}
  776. Writeln(CRCFile,crc);
  777. {$endif Test_Double_checksum_write}
  778. inc(crcindex2);
  779. end;
  780. {$endif def Test_Double_checksum}
  781. if do_interface_crc then
  782. begin
  783. interface_crc:=UpdateCrc32(interface_crc,b,len);
  784. {$ifdef Test_Double_checksum}
  785. if crc_only then
  786. begin
  787. crc_test^[crc_index]:=interface_crc;
  788. {$ifdef Test_Double_checksum_write}
  789. Writeln(CRCFile,interface_crc);
  790. {$endif Test_Double_checksum_write}
  791. if crc_index<crc_array_size then
  792. inc(crc_index);
  793. end
  794. else
  795. begin
  796. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  797. (crc_test^[crcindex]<>interface_crc) then
  798. Do_comment(V_Warning,'CRC changed');
  799. {$ifdef Test_Double_checksum_write}
  800. Writeln(CRCFile,interface_crc);
  801. {$endif Test_Double_checksum_write}
  802. inc(crcindex);
  803. end;
  804. {$endif def Test_Double_checksum}
  805. end;
  806. end;
  807. if not crc_only then
  808. writedata(b,len);
  809. inc(entryidx,len);
  810. end;
  811. procedure tppufile.putbyte(b:byte);
  812. begin
  813. writedata(b,1);
  814. inc(entryidx);
  815. end;
  816. procedure tppufile.putword(w:word);
  817. begin
  818. if change_endian then
  819. w:=swap(w);
  820. putdata(w,2);
  821. end;
  822. procedure tppufile.putlongint(l:longint);
  823. begin
  824. if change_endian then
  825. { someone added swap(l : longint) in system unit
  826. this broke the following code !! }
  827. l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
  828. putdata(l,4);
  829. end;
  830. procedure tppufile.putreal(d:ppureal);
  831. begin
  832. putdata(d,sizeof(ppureal));
  833. end;
  834. procedure tppufile.putstring(s:string);
  835. begin
  836. putdata(s,length(s)+1);
  837. end;
  838. procedure tppufile.putsmallset(var b);
  839. begin
  840. putdata(b,4);
  841. end;
  842. procedure tppufile.putnormalset(var b);
  843. begin
  844. putdata(b,32);
  845. end;
  846. procedure tppufile.tempclose;
  847. var
  848. i : word;
  849. begin
  850. if not closed then
  851. begin
  852. closepos:=filepos(f);
  853. {$I-}
  854. system.close(f);
  855. {$I+}
  856. i:=ioresult;
  857. closed:=true;
  858. tempclosed:=true;
  859. end;
  860. end;
  861. function tppufile.tempopen:boolean;
  862. var
  863. ofm : byte;
  864. begin
  865. tempopen:=false;
  866. if not closed or not tempclosed then
  867. exit;
  868. ofm:=filemode;
  869. filemode:=0;
  870. {$I-}
  871. reset(f,1);
  872. {$I+}
  873. filemode:=ofm;
  874. if ioresult<>0 then
  875. exit;
  876. closed:=false;
  877. tempclosed:=false;
  878. { restore state }
  879. seek(f,closepos);
  880. tempopen:=true;
  881. end;
  882. end.
  883. {
  884. $Log$
  885. Revision 1.48 1999-11-17 17:05:02 pierre
  886. * Notes/hints changes
  887. Revision 1.47 1999/11/06 14:34:23 peter
  888. * truncated log to 20 revs
  889. Revision 1.46 1999/09/17 09:14:56 peter
  890. * ppu header writting now uses currentppuversion
  891. Revision 1.45 1999/09/16 13:27:08 pierre
  892. + error if PPU modulename is different from what is searched
  893. (8+3 limitations!)
  894. + cond ORDERSOURCES to allow recompilation of FP
  895. if symppu.inc is changed (need PPUversion change!)
  896. Revision 1.44 1999/09/16 11:34:58 pierre
  897. * typo correction
  898. Revision 1.43 1999/09/10 18:48:09 florian
  899. * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
  900. * most things for stored properties fixed
  901. Revision 1.42 1999/08/31 15:47:56 pierre
  902. + startup conditionals stored in PPU file for debug info
  903. Revision 1.41 1999/08/30 16:21:40 pierre
  904. * tempclosing of ppufiles under dos was wrong
  905. Revision 1.40 1999/08/27 10:48:40 pierre
  906. + tppufile.tempclose and tempopen added
  907. * some changes so that nothing is writtedn to disk while
  908. calculating CRC only
  909. Revision 1.39 1999/08/24 12:01:36 michael
  910. + changes for resourcestrings
  911. Revision 1.38 1999/08/15 10:47:48 peter
  912. + normalset,smallset writing
  913. Revision 1.37 1999/08/02 23:13:20 florian
  914. * more changes to compile for the Alpha
  915. Revision 1.36 1999/07/23 16:05:25 peter
  916. * alignment is now saved in the symtable
  917. * C alignment added for records
  918. * PPU version increased to solve .12 <-> .13 probs
  919. Revision 1.35 1999/07/05 16:21:30 peter
  920. * fixed linking for units without linking necessary
  921. Revision 1.34 1999/07/03 00:29:57 peter
  922. * new link writing to the ppu, one .ppu is needed for all link types,
  923. static (.o) is now always created also when smartlinking is used
  924. Revision 1.33 1999/05/13 21:59:36 peter
  925. * removed oldppu code
  926. * warning if objpas is loaded from uses
  927. * first things for new deref writing
  928. Revision 1.32 1999/05/05 09:19:15 florian
  929. * more fixes to get it with delphi running
  930. Revision 1.31 1999/05/04 21:44:59 florian
  931. * changes to compile it with Delphi 4.0
  932. Revision 1.30 1999/04/26 18:30:00 peter
  933. * farpointerdef moved into pointerdef.is_far
  934. Revision 1.29 1999/04/26 13:31:41 peter
  935. * release storenumber,double_checksum
  936. Revision 1.28 1999/04/26 09:33:07 peter
  937. * header extended to 40 bytes so there is room for future
  938. Revision 1.27 1999/04/17 13:16:20 peter
  939. * fixes for storenumber
  940. }