ppu.pas 22 KB

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