ppu.pas 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176
  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 = 20000;
  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. CurrentPPUVersion=100;
  35. {$else newcg}
  36. CurrentPPUVersion=17;
  37. {$endif newcg}
  38. { buffer sizes }
  39. maxentrysize = 1024;
  40. {$ifdef TP}
  41. ppubufsize = 1024;
  42. {$else}
  43. ppubufsize = 16384;
  44. {$endif}
  45. {ppu entries}
  46. mainentryid = 1;
  47. subentryid = 2;
  48. {special}
  49. iberror = 0;
  50. ibstartdefs = 248;
  51. ibenddefs = 249;
  52. ibstartsyms = 250;
  53. ibendsyms = 251;
  54. ibendinterface = 252;
  55. ibendimplementation = 253;
  56. ibendbrowser = 254;
  57. ibend = 255;
  58. {general}
  59. ibmodulename = 1;
  60. ibsourcefiles = 2;
  61. ibloadunit = 3;
  62. ibinitunit = 4;
  63. iblinkunitofiles = 5;
  64. iblinkunitstaticlibs = 6;
  65. iblinkunitsharedlibs = 7;
  66. iblinkotherofiles = 8;
  67. iblinkotherstaticlibs = 9;
  68. iblinkothersharedlibs = 10;
  69. ibdbxcount = 11;
  70. ibsymref = 12;
  71. ibdefref = 13;
  72. ibendsymtablebrowser = 14;
  73. ibbeginsymtablebrowser = 15;
  74. ibusedmacros = 16;
  75. {syms}
  76. ibtypesym = 20;
  77. ibprocsym = 21;
  78. ibvarsym = 22;
  79. ibconstsym = 23;
  80. ibenumsym = 24;
  81. ibtypedconstsym = 25;
  82. ibabsolutesym = 26;
  83. ibpropertysym = 27;
  84. ibvarsym_C = 28;
  85. ibunitsym = 29; { needed for browser }
  86. iblabelsym = 30;
  87. ibfuncretsym = 31;
  88. ibsyssym = 32;
  89. {definitions}
  90. iborddef = 40;
  91. ibpointerdef = 41;
  92. ibarraydef = 42;
  93. ibprocdef = 43;
  94. ibshortstringdef = 44;
  95. ibrecorddef = 45;
  96. ibfiledef = 46;
  97. ibformaldef = 47;
  98. ibobjectdef = 48;
  99. ibenumdef = 49;
  100. ibsetdef = 50;
  101. ibprocvardef = 51;
  102. ibfloatdef = 52;
  103. ibclassrefdef = 53;
  104. iblongstringdef = 54;
  105. ibansistringdef = 55;
  106. ibwidestringdef = 56;
  107. { unit flags }
  108. uf_init = $1;
  109. uf_finalize = $2;
  110. uf_big_endian = $4;
  111. uf_has_dbx = $8;
  112. uf_has_browser = $10;
  113. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  114. uf_smart_linked = $40; { the ppu can be smartlinked }
  115. uf_static_linked = $80; { the ppu can be linked static }
  116. uf_shared_linked = $100; { the ppu can be linked shared }
  117. uf_local_browser = $200;
  118. uf_no_link = $400; { unit has no .o generated, but can still have
  119. external linking! }
  120. uf_has_resources = $800; { unit has resource section }
  121. type
  122. {$ifdef m68k}
  123. ppureal=single;
  124. {$else}
  125. ppureal=extended;
  126. {$endif}
  127. tppuerror=(ppuentrytoobig,ppuentryerror);
  128. tppuheader=packed record { 40 bytes }
  129. id : array[1..3] of char; { = 'PPU' }
  130. ver : array[1..3] of char;
  131. compiler : word;
  132. cpu : word;
  133. target : word;
  134. flags : longint;
  135. size : longint; { size of the ppufile without header }
  136. checksum : longint; { checksum for this ppufile }
  137. interface_checksum : longint;
  138. future : array[0..2] of longint;
  139. end;
  140. tppuentry=packed record
  141. id : byte;
  142. nr : byte;
  143. size : longint;
  144. end;
  145. pppufile=^tppufile;
  146. tppufile=object
  147. f : file;
  148. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  149. error : boolean;
  150. fname : string;
  151. fsize : longint;
  152. header : tppuheader;
  153. size,crc : longint;
  154. {$ifdef Test_Double_checksum}
  155. crcindex : longint;
  156. crc_index : longint;
  157. crcindex2 : longint;
  158. crc_index2 : longint;
  159. crc_test,crc_test2 : pcrc_array;
  160. {$endif def Test_Double_checksum}
  161. interface_crc : longint;
  162. do_interface_crc : boolean;
  163. crc_only : boolean; { used to calculate interface_crc before implementation }
  164. do_crc,
  165. change_endian : boolean;
  166. buf : pchar;
  167. bufstart,
  168. bufsize,
  169. bufidx : longint;
  170. entrybufstart,
  171. entrystart,
  172. entryidx : longint;
  173. entry : tppuentry;
  174. entrytyp : byte;
  175. closed,
  176. tempclosed : boolean;
  177. closepos : longint;
  178. constructor init(fn:string);
  179. destructor done;
  180. procedure flush;
  181. procedure close;
  182. function CheckPPUId:boolean;
  183. function GetPPUVersion:longint;
  184. procedure NewHeader;
  185. procedure NewEntry;
  186. {read}
  187. function open:boolean;
  188. procedure reloadbuf;
  189. procedure readdata(var b;len:longint);
  190. procedure skipdata(len:longint);
  191. function readentry:byte;
  192. function EndOfEntry:boolean;
  193. procedure getdatabuf(var b;len:longint;var result:longint);
  194. procedure getdata(var b;len:longint);
  195. function getbyte:byte;
  196. function getword:word;
  197. function getlongint:longint;
  198. function getreal:ppureal;
  199. function getstring:string;
  200. procedure getnormalset(var b);
  201. procedure getsmallset(var b);
  202. function skipuntilentry(untilb:byte):boolean;
  203. {write}
  204. function create:boolean;
  205. procedure writeheader;
  206. procedure writebuf;
  207. procedure writedata(var b;len:longint);
  208. procedure writeentry(ibnr:byte);
  209. procedure putdata(var b;len:longint);
  210. procedure putbyte(b:byte);
  211. procedure putword(w:word);
  212. procedure putlongint(l:longint);
  213. procedure putreal(d:ppureal);
  214. procedure putstring(s:string);
  215. procedure putnormalset(var b);
  216. procedure putsmallset(var b);
  217. procedure tempclose;
  218. function tempopen:boolean;
  219. end;
  220. implementation
  221. {$ifdef Test_Double_checksum}
  222. uses
  223. comphook;
  224. {$endif def Test_Double_checksum}
  225. {*****************************************************************************
  226. Crc 32
  227. *****************************************************************************}
  228. var
  229. {$ifdef Delphi}
  230. Crc32Tbl : array[0..255] of longword;
  231. {$else Delphi}
  232. Crc32Tbl : array[0..255] of longint;
  233. {$endif Delphi}
  234. procedure MakeCRC32Tbl;
  235. var
  236. {$ifdef Delphi}
  237. crc : longword;
  238. {$else Delphi}
  239. crc : longint;
  240. {$endif Delphi}
  241. i,n : byte;
  242. begin
  243. for i:=0 to 255 do
  244. begin
  245. crc:=i;
  246. for n:=1 to 8 do
  247. if odd(crc) then
  248. crc:=(crc shr 1) xor $edb88320
  249. else
  250. crc:=crc shr 1;
  251. Crc32Tbl[i]:=crc;
  252. end;
  253. end;
  254. {$ifopt R+}
  255. {$define Range_check_on}
  256. {$endif opt R+}
  257. {$R- needed here }
  258. {CRC 32}
  259. Function Crc32(Const HStr:String):longint;
  260. var
  261. i,InitCrc : longint;
  262. begin
  263. if Crc32Tbl[1]=0 then
  264. MakeCrc32Tbl;
  265. InitCrc:=$ffffffff;
  266. for i:=1to Length(Hstr) do
  267. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
  268. Crc32:=InitCrc;
  269. end;
  270. Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
  271. var
  272. i : word;
  273. p : pchar;
  274. begin
  275. if Crc32Tbl[1]=0 then
  276. MakeCrc32Tbl;
  277. p:=@InBuf;
  278. for i:=1to InLen do
  279. begin
  280. InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
  281. inc(longint(p));
  282. end;
  283. UpdateCrc32:=InitCrc;
  284. end;
  285. Function UpdCrc32(InitCrc:longint;b:byte):longint;
  286. begin
  287. if Crc32Tbl[1]=0 then
  288. MakeCrc32Tbl;
  289. UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
  290. end;
  291. {$ifdef Range_check_on}
  292. {$R+}
  293. {$undef Range_check_on}
  294. {$endif Range_check_on}
  295. {*****************************************************************************
  296. TPPUFile
  297. *****************************************************************************}
  298. constructor tppufile.init(fn:string);
  299. begin
  300. fname:=fn;
  301. change_endian:=false;
  302. crc_only:=false;
  303. Mode:=0;
  304. NewHeader;
  305. Error:=false;
  306. closed:=true;
  307. tempclosed:=false;
  308. getmem(buf,ppubufsize);
  309. end;
  310. destructor tppufile.done;
  311. begin
  312. close;
  313. if assigned(buf) then
  314. freemem(buf,ppubufsize);
  315. end;
  316. procedure tppufile.flush;
  317. begin
  318. if Mode=2 then
  319. writebuf;
  320. end;
  321. procedure tppufile.close;
  322. var
  323. i : word;
  324. begin
  325. if Mode<>0 then
  326. begin
  327. Flush;
  328. {$I-}
  329. system.close(f);
  330. {$I+}
  331. i:=ioresult;
  332. Mode:=0;
  333. closed:=true;
  334. end;
  335. end;
  336. function tppufile.CheckPPUId:boolean;
  337. begin
  338. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  339. end;
  340. function tppufile.GetPPUVersion:longint;
  341. var
  342. l : longint;
  343. code : integer;
  344. begin
  345. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  346. if code=0 then
  347. GetPPUVersion:=l
  348. else
  349. GetPPUVersion:=0;
  350. end;
  351. procedure tppufile.NewHeader;
  352. begin
  353. fillchar(header,sizeof(tppuheader),0);
  354. with header do
  355. begin
  356. Id[1]:='P';
  357. Id[2]:='P';
  358. Id[3]:='U';
  359. Ver[1]:='0';
  360. Ver[2]:='1';
  361. Ver[3]:='7';
  362. end;
  363. end;
  364. {*****************************************************************************
  365. TPPUFile Reading
  366. *****************************************************************************}
  367. function tppufile.open:boolean;
  368. var
  369. ofmode : byte;
  370. {$ifdef delphi}
  371. i : integer;
  372. {$else delphi}
  373. i : word;
  374. {$endif delphi}
  375. begin
  376. open:=false;
  377. assign(f,fname);
  378. ofmode:=filemode;
  379. filemode:=$0;
  380. {$I-}
  381. reset(f,1);
  382. {$I+}
  383. filemode:=ofmode;
  384. if ioresult<>0 then
  385. exit;
  386. closed:=false;
  387. {read ppuheader}
  388. fsize:=filesize(f);
  389. if fsize<sizeof(tppuheader) then
  390. exit;
  391. blockread(f,header,sizeof(tppuheader),i);
  392. {reset buffer}
  393. bufstart:=i;
  394. bufsize:=0;
  395. bufidx:=0;
  396. Mode:=1;
  397. FillChar(entry,sizeof(tppuentry),0);
  398. entryidx:=0;
  399. entrystart:=0;
  400. entrybufstart:=0;
  401. Error:=false;
  402. open:=true;
  403. end;
  404. procedure tppufile.reloadbuf;
  405. {$ifdef TP}
  406. var
  407. i : word;
  408. {$endif}
  409. begin
  410. inc(bufstart,bufsize);
  411. {$ifdef TP}
  412. blockread(f,buf^,ppubufsize,i);
  413. bufsize:=i;
  414. {$else}
  415. blockread(f,buf^,ppubufsize,bufsize);
  416. {$endif}
  417. bufidx:=0;
  418. end;
  419. procedure tppufile.readdata(var b;len:longint);
  420. var
  421. p : pchar;
  422. left,
  423. idx : longint;
  424. begin
  425. p:=pchar(@b);
  426. idx:=0;
  427. while len>0 do
  428. begin
  429. left:=bufsize-bufidx;
  430. if len>left then
  431. begin
  432. move(buf[bufidx],p[idx],left);
  433. dec(len,left);
  434. inc(idx,left);
  435. reloadbuf;
  436. if bufsize=0 then
  437. exit;
  438. end
  439. else
  440. begin
  441. move(buf[bufidx],p[idx],len);
  442. inc(bufidx,len);
  443. exit;
  444. end;
  445. end;
  446. end;
  447. procedure tppufile.skipdata(len:longint);
  448. var
  449. left : longint;
  450. begin
  451. while len>0 do
  452. begin
  453. left:=bufsize-bufidx;
  454. if len>left then
  455. begin
  456. dec(len,left);
  457. reloadbuf;
  458. if bufsize=0 then
  459. exit;
  460. end
  461. else
  462. begin
  463. inc(bufidx,len);
  464. exit;
  465. end;
  466. end;
  467. end;
  468. function tppufile.readentry:byte;
  469. begin
  470. if entryidx<entry.size then
  471. skipdata(entry.size-entryidx);
  472. readdata(entry,sizeof(tppuentry));
  473. entrystart:=bufstart+bufidx;
  474. entryidx:=0;
  475. if not(entry.id in [mainentryid,subentryid]) then
  476. begin
  477. readentry:=iberror;
  478. error:=true;
  479. exit;
  480. end;
  481. readentry:=entry.nr;
  482. end;
  483. function tppufile.endofentry:boolean;
  484. begin
  485. endofentry:=(entryidx>=entry.size);
  486. end;
  487. procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
  488. begin
  489. if entryidx+len>entry.size then
  490. result:=entry.size-entryidx
  491. else
  492. result:=len;
  493. readdata(b,result);
  494. inc(entryidx,result);
  495. end;
  496. procedure tppufile.getdata(var b;len:longint);
  497. begin
  498. if entryidx+len>entry.size then
  499. begin
  500. error:=true;
  501. exit;
  502. end;
  503. readdata(b,len);
  504. inc(entryidx,len);
  505. end;
  506. function tppufile.getbyte:byte;
  507. var
  508. b : byte;
  509. begin
  510. if entryidx+1>entry.size then
  511. begin
  512. error:=true;
  513. getbyte:=0;
  514. exit;
  515. end;
  516. readdata(b,1);
  517. getbyte:=b;
  518. inc(entryidx);
  519. end;
  520. function tppufile.getword:word;
  521. type
  522. pword = ^word;
  523. var
  524. w : word;
  525. begin
  526. if entryidx+2>entry.size then
  527. begin
  528. error:=true;
  529. getword:=0;
  530. exit;
  531. end;
  532. readdata(w,2);
  533. if change_endian then
  534. getword:=swap(w)
  535. else
  536. getword:=w;
  537. inc(entryidx,2);
  538. end;
  539. function tppufile.getlongint:longint;
  540. type
  541. plongint = ^longint;
  542. var
  543. l : longint;
  544. begin
  545. if entryidx+4>entry.size then
  546. begin
  547. error:=true;
  548. getlongint:=0;
  549. exit;
  550. end;
  551. readdata(l,4);
  552. if change_endian then
  553. { someone added swap(l : longint) in system unit
  554. this broke the following code !! }
  555. getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
  556. else
  557. getlongint:=l;
  558. inc(entryidx,4);
  559. end;
  560. function tppufile.getreal:ppureal;
  561. type
  562. pppureal = ^ppureal;
  563. var
  564. d : ppureal;
  565. begin
  566. if entryidx+sizeof(ppureal)>entry.size then
  567. begin
  568. error:=true;
  569. getreal:=0;
  570. exit;
  571. end;
  572. readdata(d,sizeof(ppureal));
  573. getreal:=d;
  574. inc(entryidx,sizeof(ppureal));
  575. end;
  576. function tppufile.getstring:string;
  577. var
  578. s : string;
  579. begin
  580. {$ifndef TP}
  581. {$ifopt H+}
  582. setlength(s,getbyte);
  583. {$else}
  584. s[0]:=chr(getbyte);
  585. {$endif}
  586. {$else}
  587. s[0]:=chr(getbyte);
  588. {$endif}
  589. if entryidx+length(s)>entry.size then
  590. begin
  591. error:=true;
  592. exit;
  593. end;
  594. ReadData(s[1],length(s));
  595. getstring:=s;
  596. inc(entryidx,length(s));
  597. end;
  598. procedure tppufile.getsmallset(var b);
  599. begin
  600. getdata(b,4);
  601. end;
  602. procedure tppufile.getnormalset(var b);
  603. begin
  604. getdata(b,32);
  605. end;
  606. function tppufile.skipuntilentry(untilb:byte):boolean;
  607. var
  608. b : byte;
  609. begin
  610. repeat
  611. b:=readentry;
  612. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  613. skipuntilentry:=(b=untilb);
  614. end;
  615. {*****************************************************************************
  616. TPPUFile Writing
  617. *****************************************************************************}
  618. function tppufile.create:boolean;
  619. begin
  620. create:=false;
  621. if not crc_only then
  622. begin
  623. assign(f,fname);
  624. {$I-}
  625. rewrite(f,1);
  626. {$I+}
  627. if ioresult<>0 then
  628. exit;
  629. Mode:=2;
  630. {write header for sure}
  631. blockwrite(f,header,sizeof(tppuheader));
  632. end;
  633. bufsize:=ppubufsize;
  634. bufstart:=sizeof(tppuheader);
  635. bufidx:=0;
  636. {reset}
  637. crc:=$ffffffff;
  638. interface_crc:=$ffffffff;
  639. do_interface_crc:=true;
  640. Error:=false;
  641. do_crc:=true;
  642. size:=0;
  643. entrytyp:=mainentryid;
  644. {start}
  645. NewEntry;
  646. create:=true;
  647. end;
  648. procedure tppufile.writeheader;
  649. var
  650. opos : longint;
  651. begin
  652. { flush buffer }
  653. writebuf;
  654. { update size (w/o header!) in the header }
  655. header.size:=bufstart-sizeof(tppuheader);
  656. { write header and restore filepos after it }
  657. opos:=filepos(f);
  658. seek(f,0);
  659. blockwrite(f,header,sizeof(tppuheader));
  660. seek(f,opos);
  661. end;
  662. procedure tppufile.writebuf;
  663. begin
  664. if not crc_only then
  665. blockwrite(f,buf^,bufidx);
  666. inc(bufstart,bufidx);
  667. bufidx:=0;
  668. end;
  669. procedure tppufile.writedata(var b;len:longint);
  670. var
  671. p : pchar;
  672. left,
  673. idx : longint;
  674. begin
  675. if crc_only then
  676. exit;
  677. p:=pchar(@b);
  678. idx:=0;
  679. while len>0 do
  680. begin
  681. left:=bufsize-bufidx;
  682. if len>left then
  683. begin
  684. move(p[idx],buf[bufidx],left);
  685. dec(len,left);
  686. inc(idx,left);
  687. inc(bufidx,left);
  688. writebuf;
  689. end
  690. else
  691. begin
  692. move(p[idx],buf[bufidx],len);
  693. inc(bufidx,len);
  694. exit;
  695. end;
  696. end;
  697. end;
  698. procedure tppufile.NewEntry;
  699. begin
  700. with entry do
  701. begin
  702. id:=entrytyp;
  703. nr:=ibend;
  704. size:=0;
  705. end;
  706. {Reset Entry State}
  707. entryidx:=0;
  708. entrybufstart:=bufstart;
  709. entrystart:=bufstart+bufidx;
  710. {Alloc in buffer}
  711. writedata(entry,sizeof(tppuentry));
  712. end;
  713. procedure tppufile.writeentry(ibnr:byte);
  714. var
  715. opos : longint;
  716. begin
  717. {create entry}
  718. entry.id:=entrytyp;
  719. entry.nr:=ibnr;
  720. entry.size:=entryidx;
  721. {it's already been sent to disk ?}
  722. if entrybufstart<>bufstart then
  723. begin
  724. if not crc_only then
  725. begin
  726. {flush to be sure}
  727. WriteBuf;
  728. {write entry}
  729. opos:=filepos(f);
  730. seek(f,entrystart);
  731. blockwrite(f,entry,sizeof(tppuentry));
  732. seek(f,opos);
  733. end;
  734. entrybufstart:=bufstart;
  735. end
  736. else
  737. move(entry,buf[entrystart-bufstart],sizeof(entry));
  738. {Add New Entry, which is ibend by default}
  739. entrystart:=bufstart+bufidx; {next entry position}
  740. NewEntry;
  741. end;
  742. procedure tppufile.putdata(var b;len:longint);
  743. begin
  744. if do_crc then
  745. begin
  746. crc:=UpdateCrc32(crc,b,len);
  747. {$ifdef Test_Double_checksum}
  748. if crc_only then
  749. begin
  750. crc_test2^[crc_index2]:=crc;
  751. {$ifdef Test_Double_checksum_write}
  752. Writeln(CRCFile,crc);
  753. {$endif Test_Double_checksum_write}
  754. if crc_index2<crc_array_size then
  755. inc(crc_index2);
  756. end
  757. else
  758. begin
  759. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  760. (crc_test2^[crcindex2]<>crc) then
  761. Do_comment(V_Warning,'impl CRC changed');
  762. {$ifdef Test_Double_checksum_write}
  763. Writeln(CRCFile,crc);
  764. {$endif Test_Double_checksum_write}
  765. inc(crcindex2);
  766. end;
  767. {$endif def Test_Double_checksum}
  768. if do_interface_crc then
  769. begin
  770. interface_crc:=UpdateCrc32(interface_crc,b,len);
  771. {$ifdef Test_Double_checksum}
  772. if crc_only then
  773. begin
  774. crc_test^[crc_index]:=interface_crc;
  775. {$ifdef Test_Double_checksum_write}
  776. Writeln(CRCFile,interface_crc);
  777. {$endif Test_Double_checksum_write}
  778. if crc_index<crc_array_size then
  779. inc(crc_index);
  780. end
  781. else
  782. begin
  783. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  784. (crc_test^[crcindex]<>interface_crc) then
  785. Do_comment(V_Warning,'CRC changed');
  786. {$ifdef Test_Double_checksum_write}
  787. Writeln(CRCFile,interface_crc);
  788. {$endif Test_Double_checksum_write}
  789. inc(crcindex);
  790. end;
  791. {$endif def Test_Double_checksum}
  792. end;
  793. end;
  794. if not crc_only then
  795. writedata(b,len);
  796. inc(entryidx,len);
  797. end;
  798. procedure tppufile.putbyte(b:byte);
  799. begin
  800. writedata(b,1);
  801. inc(entryidx);
  802. end;
  803. procedure tppufile.putword(w:word);
  804. begin
  805. if change_endian then
  806. w:=swap(w);
  807. putdata(w,2);
  808. end;
  809. procedure tppufile.putlongint(l:longint);
  810. begin
  811. if change_endian then
  812. { someone added swap(l : longint) in system unit
  813. this broke the following code !! }
  814. l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
  815. putdata(l,4);
  816. end;
  817. procedure tppufile.putreal(d:ppureal);
  818. begin
  819. putdata(d,sizeof(ppureal));
  820. end;
  821. procedure tppufile.putstring(s:string);
  822. begin
  823. putdata(s,length(s)+1);
  824. end;
  825. procedure tppufile.putsmallset(var b);
  826. begin
  827. putdata(b,4);
  828. end;
  829. procedure tppufile.putnormalset(var b);
  830. begin
  831. putdata(b,32);
  832. end;
  833. procedure tppufile.tempclose;
  834. var
  835. i : word;
  836. begin
  837. if not closed then
  838. begin
  839. closepos:=filepos(f);
  840. {$I-}
  841. system.close(f);
  842. {$I+}
  843. i:=ioresult;
  844. closed:=true;
  845. tempclosed:=true;
  846. end;
  847. end;
  848. function tppufile.tempopen:boolean;
  849. var
  850. ofm : byte;
  851. begin
  852. tempopen:=false;
  853. if not closed or not tempclosed then
  854. exit;
  855. ofm:=filemode;
  856. filemode:=0;
  857. {$I-}
  858. reset(f,1);
  859. {$I+}
  860. filemode:=ofm;
  861. if ioresult<>0 then
  862. exit;
  863. closed:=false;
  864. tempclosed:=false;
  865. { restore state }
  866. seek(f,closepos);
  867. tempopen:=true;
  868. end;
  869. end.
  870. {
  871. $Log$
  872. Revision 1.43 1999-09-10 18:48:09 florian
  873. * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
  874. * most things for stored properties fixed
  875. Revision 1.42 1999/08/31 15:47:56 pierre
  876. + startup conditionnals stored in PPU file for debug info
  877. Revision 1.41 1999/08/30 16:21:40 pierre
  878. * tempclosing of ppufiles under dos was wrong
  879. Revision 1.40 1999/08/27 10:48:40 pierre
  880. + tppufile.tempclose and tempopen added
  881. * some changes so that nothing is writtedn to disk while
  882. calculating CRC only
  883. Revision 1.39 1999/08/24 12:01:36 michael
  884. + changes for resourcestrings
  885. Revision 1.38 1999/08/15 10:47:48 peter
  886. + normalset,smallset writing
  887. Revision 1.37 1999/08/02 23:13:20 florian
  888. * more changes to compile for the Alpha
  889. Revision 1.36 1999/07/23 16:05:25 peter
  890. * alignment is now saved in the symtable
  891. * C alignment added for records
  892. * PPU version increased to solve .12 <-> .13 probs
  893. Revision 1.35 1999/07/05 16:21:30 peter
  894. * fixed linking for units without linking necessary
  895. Revision 1.34 1999/07/03 00:29:57 peter
  896. * new link writing to the ppu, one .ppu is needed for all link types,
  897. static (.o) is now always created also when smartlinking is used
  898. Revision 1.33 1999/05/13 21:59:36 peter
  899. * removed oldppu code
  900. * warning if objpas is loaded from uses
  901. * first things for new deref writing
  902. Revision 1.32 1999/05/05 09:19:15 florian
  903. * more fixes to get it with delphi running
  904. Revision 1.31 1999/05/04 21:44:59 florian
  905. * changes to compile it with Delphi 4.0
  906. Revision 1.30 1999/04/26 18:30:00 peter
  907. * farpointerdef moved into pointerdef.is_far
  908. Revision 1.29 1999/04/26 13:31:41 peter
  909. * release storenumber,double_checksum
  910. Revision 1.28 1999/04/26 09:33:07 peter
  911. * header extended to 40 bytes so there is room for future
  912. Revision 1.27 1999/04/17 13:16:20 peter
  913. * fixes for storenumber
  914. Revision 1.26 1999/04/07 15:39:31 pierre
  915. + double_checksum code added
  916. Revision 1.25 1999/03/02 13:49:18 peter
  917. * renamed loadunit_int -> loadunit
  918. Revision 1.24 1999/02/22 13:07:00 pierre
  919. + -b and -bl options work !
  920. + cs_local_browser ($L+) is disabled if cs_browser ($Y+)
  921. is not enabled when quitting global section
  922. * local vars and procedures are not yet stored into PPU
  923. Revision 1.23 1999/02/16 00:48:24 peter
  924. * save in the ppu if linked with obj file instead of using the
  925. library flag, so the .inc files are also checked
  926. Revision 1.22 1999/02/05 08:54:29 pierre
  927. + linkofiles splitted inot linkofiles and linkunitfiles
  928. because linkofiles must be stored with directory
  929. to enabled linking of different objects with same name
  930. in a different directory
  931. Revision 1.21 1998/12/30 22:15:50 peter
  932. + farpointer type
  933. * absolutesym now also stores if its far
  934. Revision 1.20 1998/11/30 16:34:45 pierre
  935. * corrected problems with rangecheck
  936. + added needed code for no rangecheck in CRC32 functions in ppu unit
  937. * enumdef lso need its rangenr reset to zero
  938. when calling reset_global_defs
  939. Revision 1.19 1998/11/16 15:41:42 peter
  940. * tp7 didn't like my ifopt H+ :(
  941. Revision 1.18 1998/11/16 12:18:03 peter
  942. * H+ fixes
  943. Revision 1.17 1998/10/14 10:45:08 pierre
  944. * ppu problems for m68k fixed (at least in cross compiling)
  945. * one last memory leak for sysamiga fixed
  946. * the amiga RTL compiles now completely !!
  947. Revision 1.16 1998/09/24 23:49:14 peter
  948. + aktmodeswitches
  949. Revision 1.15 1998/09/23 15:39:10 pierre
  950. * browser bugfixes
  951. was adding a reference when looking for the symbol
  952. if -bSYM_NAME was used
  953. Revision 1.14 1998/09/21 10:00:07 peter
  954. * store number of defs in ppu file
  955. Revision 1.13 1998/09/21 08:45:18 pierre
  956. + added vmt_offset in tobjectdef.write for fututre use
  957. (first steps to have objects without vmt if no virtual !!)
  958. + added fpu_used field for tabstractprocdef :
  959. sets this level to 2 if the functions return with value in FPU
  960. (is then set to correct value at parsing of implementation)
  961. THIS MIGHT refuse some code with FPU expression too complex
  962. that were accepted before and even in some cases
  963. that don't overflow in fact
  964. ( like if f : float; is a forward that finally in implementation
  965. only uses one fpu register !!)
  966. Nevertheless I think that it will improve security on
  967. FPU operations !!
  968. * most other changes only for UseBrowser code
  969. (added symtable references for record and objects)
  970. local switch for refs to args and local of each function
  971. (static symtable still missing)
  972. UseBrowser still not stable and probably broken by
  973. the definition hash array !!
  974. Revision 1.12 1998/09/18 08:01:37 pierre
  975. + improvement on the usebrowser part
  976. (does not work correctly for now)
  977. Revision 1.11 1998/09/11 15:16:47 peter
  978. * merge fixes
  979. Revision 1.10.2.1 1998/09/11 15:15:04 peter
  980. * fixed not in [] bug
  981. Revision 1.10 1998/08/31 12:26:30 peter
  982. * m68k and palmos updates from surebugfixes
  983. Revision 1.9 1998/08/17 09:17:51 peter
  984. * static/shared linking updates
  985. Revision 1.8 1998/08/11 15:31:40 peter
  986. * write extended to ppu file
  987. * new version 0.99.7
  988. Revision 1.7 1998/06/25 10:51:01 pierre
  989. * removed a remaining ifndef NEWPPU
  990. replaced by ifdef OLDPPU
  991. * added uf_finalize to ppu unit
  992. Revision 1.6 1998/06/16 08:56:26 peter
  993. + targetcpu
  994. * cleaner pmodules for newppu
  995. Revision 1.5 1998/06/13 00:10:12 peter
  996. * working browser and newppu
  997. * some small fixes against crashes which occured in bp7 (but not in
  998. fpc?!)
  999. Revision 1.4 1998/06/09 16:01:48 pierre
  1000. + added procedure directive parsing for procvars
  1001. (accepted are popstack cdecl and pascal)
  1002. + added C vars with the following syntax
  1003. var C calias 'true_c_name';(can be followed by external)
  1004. reason is that you must add the Cprefix
  1005. which is target dependent
  1006. Revision 1.3 1998/05/28 14:40:26 peter
  1007. * fixes for newppu, remake3 works now with it
  1008. Revision 1.2 1998/05/27 19:45:08 peter
  1009. * symtable.pas splitted into includefiles
  1010. * symtable adapted for $ifdef NEWPPU
  1011. Revision 1.1 1998/05/12 10:56:07 peter
  1012. + the ppufile object unit
  1013. }