ppu.pas 25 KB

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