ppu.pas 22 KB

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