ppu.pas 26 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171
  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. freemem(buf,ppubufsize);
  314. end;
  315. procedure tppufile.flush;
  316. begin
  317. if Mode=2 then
  318. writebuf;
  319. end;
  320. procedure tppufile.close;
  321. var
  322. i : word;
  323. begin
  324. if Mode<>0 then
  325. begin
  326. Flush;
  327. {$I-}
  328. system.close(f);
  329. {$I+}
  330. i:=ioresult;
  331. Mode:=0;
  332. closed:=true;
  333. end;
  334. end;
  335. function tppufile.CheckPPUId:boolean;
  336. begin
  337. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  338. end;
  339. function tppufile.GetPPUVersion:longint;
  340. var
  341. l : longint;
  342. code : integer;
  343. begin
  344. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  345. if code=0 then
  346. GetPPUVersion:=l
  347. else
  348. GetPPUVersion:=0;
  349. end;
  350. procedure tppufile.NewHeader;
  351. begin
  352. fillchar(header,sizeof(tppuheader),0);
  353. with header do
  354. begin
  355. Id[1]:='P';
  356. Id[2]:='P';
  357. Id[3]:='U';
  358. Ver[1]:='0';
  359. Ver[2]:='1';
  360. Ver[3]:='7';
  361. end;
  362. end;
  363. {*****************************************************************************
  364. TPPUFile Reading
  365. *****************************************************************************}
  366. function tppufile.open:boolean;
  367. var
  368. ofmode : byte;
  369. {$ifdef delphi}
  370. i : integer;
  371. {$else delphi}
  372. i : word;
  373. {$endif delphi}
  374. begin
  375. open:=false;
  376. assign(f,fname);
  377. ofmode:=filemode;
  378. filemode:=$0;
  379. {$I-}
  380. reset(f,1);
  381. {$I+}
  382. filemode:=ofmode;
  383. if ioresult<>0 then
  384. exit;
  385. closed:=false;
  386. {read ppuheader}
  387. fsize:=filesize(f);
  388. if fsize<sizeof(tppuheader) then
  389. exit;
  390. blockread(f,header,sizeof(tppuheader),i);
  391. {reset buffer}
  392. bufstart:=i;
  393. bufsize:=0;
  394. bufidx:=0;
  395. Mode:=1;
  396. FillChar(entry,sizeof(tppuentry),0);
  397. entryidx:=0;
  398. entrystart:=0;
  399. entrybufstart:=0;
  400. Error:=false;
  401. open:=true;
  402. end;
  403. procedure tppufile.reloadbuf;
  404. {$ifdef TP}
  405. var
  406. i : word;
  407. {$endif}
  408. begin
  409. inc(bufstart,bufsize);
  410. {$ifdef TP}
  411. blockread(f,buf^,ppubufsize,i);
  412. bufsize:=i;
  413. {$else}
  414. blockread(f,buf^,ppubufsize,bufsize);
  415. {$endif}
  416. bufidx:=0;
  417. end;
  418. procedure tppufile.readdata(var b;len:longint);
  419. var
  420. p : pchar;
  421. left,
  422. idx : longint;
  423. begin
  424. p:=pchar(@b);
  425. idx:=0;
  426. while len>0 do
  427. begin
  428. left:=bufsize-bufidx;
  429. if len>left then
  430. begin
  431. move(buf[bufidx],p[idx],left);
  432. dec(len,left);
  433. inc(idx,left);
  434. reloadbuf;
  435. if bufsize=0 then
  436. exit;
  437. end
  438. else
  439. begin
  440. move(buf[bufidx],p[idx],len);
  441. inc(bufidx,len);
  442. exit;
  443. end;
  444. end;
  445. end;
  446. procedure tppufile.skipdata(len:longint);
  447. var
  448. left : longint;
  449. begin
  450. while len>0 do
  451. begin
  452. left:=bufsize-bufidx;
  453. if len>left then
  454. begin
  455. dec(len,left);
  456. reloadbuf;
  457. if bufsize=0 then
  458. exit;
  459. end
  460. else
  461. begin
  462. inc(bufidx,len);
  463. exit;
  464. end;
  465. end;
  466. end;
  467. function tppufile.readentry:byte;
  468. begin
  469. if entryidx<entry.size then
  470. skipdata(entry.size-entryidx);
  471. readdata(entry,sizeof(tppuentry));
  472. entrystart:=bufstart+bufidx;
  473. entryidx:=0;
  474. if not(entry.id in [mainentryid,subentryid]) then
  475. begin
  476. readentry:=iberror;
  477. error:=true;
  478. exit;
  479. end;
  480. readentry:=entry.nr;
  481. end;
  482. function tppufile.endofentry:boolean;
  483. begin
  484. endofentry:=(entryidx>=entry.size);
  485. end;
  486. procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
  487. begin
  488. if entryidx+len>entry.size then
  489. result:=entry.size-entryidx
  490. else
  491. result:=len;
  492. readdata(b,result);
  493. inc(entryidx,result);
  494. end;
  495. procedure tppufile.getdata(var b;len:longint);
  496. begin
  497. if entryidx+len>entry.size then
  498. begin
  499. error:=true;
  500. exit;
  501. end;
  502. readdata(b,len);
  503. inc(entryidx,len);
  504. end;
  505. function tppufile.getbyte:byte;
  506. var
  507. b : byte;
  508. begin
  509. if entryidx+1>entry.size then
  510. begin
  511. error:=true;
  512. getbyte:=0;
  513. exit;
  514. end;
  515. readdata(b,1);
  516. getbyte:=b;
  517. inc(entryidx);
  518. end;
  519. function tppufile.getword:word;
  520. type
  521. pword = ^word;
  522. var
  523. w : word;
  524. begin
  525. if entryidx+2>entry.size then
  526. begin
  527. error:=true;
  528. getword:=0;
  529. exit;
  530. end;
  531. readdata(w,2);
  532. if change_endian then
  533. getword:=swap(w)
  534. else
  535. getword:=w;
  536. inc(entryidx,2);
  537. end;
  538. function tppufile.getlongint:longint;
  539. type
  540. plongint = ^longint;
  541. var
  542. l : longint;
  543. begin
  544. if entryidx+4>entry.size then
  545. begin
  546. error:=true;
  547. getlongint:=0;
  548. exit;
  549. end;
  550. readdata(l,4);
  551. if change_endian then
  552. { someone added swap(l : longint) in system unit
  553. this broke the following code !! }
  554. getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
  555. else
  556. getlongint:=l;
  557. inc(entryidx,4);
  558. end;
  559. function tppufile.getreal:ppureal;
  560. type
  561. pppureal = ^ppureal;
  562. var
  563. d : ppureal;
  564. begin
  565. if entryidx+sizeof(ppureal)>entry.size then
  566. begin
  567. error:=true;
  568. getreal:=0;
  569. exit;
  570. end;
  571. readdata(d,sizeof(ppureal));
  572. getreal:=d;
  573. inc(entryidx,sizeof(ppureal));
  574. end;
  575. function tppufile.getstring:string;
  576. var
  577. s : string;
  578. begin
  579. {$ifndef TP}
  580. {$ifopt H+}
  581. setlength(s,getbyte);
  582. {$else}
  583. s[0]:=chr(getbyte);
  584. {$endif}
  585. {$else}
  586. s[0]:=chr(getbyte);
  587. {$endif}
  588. if entryidx+length(s)>entry.size then
  589. begin
  590. error:=true;
  591. exit;
  592. end;
  593. ReadData(s[1],length(s));
  594. getstring:=s;
  595. inc(entryidx,length(s));
  596. end;
  597. procedure tppufile.getsmallset(var b);
  598. begin
  599. getdata(b,4);
  600. end;
  601. procedure tppufile.getnormalset(var b);
  602. begin
  603. getdata(b,32);
  604. end;
  605. function tppufile.skipuntilentry(untilb:byte):boolean;
  606. var
  607. b : byte;
  608. begin
  609. repeat
  610. b:=readentry;
  611. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  612. skipuntilentry:=(b=untilb);
  613. end;
  614. {*****************************************************************************
  615. TPPUFile Writing
  616. *****************************************************************************}
  617. function tppufile.create:boolean;
  618. begin
  619. create:=false;
  620. if not crc_only then
  621. begin
  622. assign(f,fname);
  623. {$I-}
  624. rewrite(f,1);
  625. {$I+}
  626. if ioresult<>0 then
  627. exit;
  628. Mode:=2;
  629. {write header for sure}
  630. blockwrite(f,header,sizeof(tppuheader));
  631. end;
  632. bufsize:=ppubufsize;
  633. bufstart:=sizeof(tppuheader);
  634. bufidx:=0;
  635. {reset}
  636. crc:=$ffffffff;
  637. interface_crc:=$ffffffff;
  638. do_interface_crc:=true;
  639. Error:=false;
  640. do_crc:=true;
  641. size:=0;
  642. entrytyp:=mainentryid;
  643. {start}
  644. NewEntry;
  645. create:=true;
  646. end;
  647. procedure tppufile.writeheader;
  648. var
  649. opos : longint;
  650. begin
  651. { flush buffer }
  652. writebuf;
  653. { update size (w/o header!) in the header }
  654. header.size:=bufstart-sizeof(tppuheader);
  655. { write header and restore filepos after it }
  656. opos:=filepos(f);
  657. seek(f,0);
  658. blockwrite(f,header,sizeof(tppuheader));
  659. seek(f,opos);
  660. end;
  661. procedure tppufile.writebuf;
  662. begin
  663. if not crc_only then
  664. blockwrite(f,buf^,bufidx);
  665. inc(bufstart,bufidx);
  666. bufidx:=0;
  667. end;
  668. procedure tppufile.writedata(var b;len:longint);
  669. var
  670. p : pchar;
  671. left,
  672. idx : longint;
  673. begin
  674. if crc_only then
  675. exit;
  676. p:=pchar(@b);
  677. idx:=0;
  678. while len>0 do
  679. begin
  680. left:=bufsize-bufidx;
  681. if len>left then
  682. begin
  683. move(p[idx],buf[bufidx],left);
  684. dec(len,left);
  685. inc(idx,left);
  686. inc(bufidx,left);
  687. writebuf;
  688. end
  689. else
  690. begin
  691. move(p[idx],buf[bufidx],len);
  692. inc(bufidx,len);
  693. exit;
  694. end;
  695. end;
  696. end;
  697. procedure tppufile.NewEntry;
  698. begin
  699. with entry do
  700. begin
  701. id:=entrytyp;
  702. nr:=ibend;
  703. size:=0;
  704. end;
  705. {Reset Entry State}
  706. entryidx:=0;
  707. entrybufstart:=bufstart;
  708. entrystart:=bufstart+bufidx;
  709. {Alloc in buffer}
  710. writedata(entry,sizeof(tppuentry));
  711. end;
  712. procedure tppufile.writeentry(ibnr:byte);
  713. var
  714. opos : longint;
  715. begin
  716. {create entry}
  717. entry.id:=entrytyp;
  718. entry.nr:=ibnr;
  719. entry.size:=entryidx;
  720. {it's already been sent to disk ?}
  721. if entrybufstart<>bufstart then
  722. begin
  723. if not crc_only then
  724. begin
  725. {flush to be sure}
  726. WriteBuf;
  727. {write entry}
  728. opos:=filepos(f);
  729. seek(f,entrystart);
  730. blockwrite(f,entry,sizeof(tppuentry));
  731. seek(f,opos);
  732. end;
  733. entrybufstart:=bufstart;
  734. end
  735. else
  736. move(entry,buf[entrystart-bufstart],sizeof(entry));
  737. {Add New Entry, which is ibend by default}
  738. entrystart:=bufstart+bufidx; {next entry position}
  739. NewEntry;
  740. end;
  741. procedure tppufile.putdata(var b;len:longint);
  742. begin
  743. if do_crc then
  744. begin
  745. crc:=UpdateCrc32(crc,b,len);
  746. {$ifdef Test_Double_checksum}
  747. if crc_only then
  748. begin
  749. crc_test2^[crc_index2]:=crc;
  750. {$ifdef Test_Double_checksum_write}
  751. Writeln(CRCFile,crc);
  752. {$endif Test_Double_checksum_write}
  753. if crc_index2<crc_array_size then
  754. inc(crc_index2);
  755. end
  756. else
  757. begin
  758. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  759. (crc_test2^[crcindex2]<>crc) then
  760. Do_comment(V_Warning,'impl CRC changed');
  761. {$ifdef Test_Double_checksum_write}
  762. Writeln(CRCFile,crc);
  763. {$endif Test_Double_checksum_write}
  764. inc(crcindex2);
  765. end;
  766. {$endif def Test_Double_checksum}
  767. if do_interface_crc then
  768. begin
  769. interface_crc:=UpdateCrc32(interface_crc,b,len);
  770. {$ifdef Test_Double_checksum}
  771. if crc_only then
  772. begin
  773. crc_test^[crc_index]:=interface_crc;
  774. {$ifdef Test_Double_checksum_write}
  775. Writeln(CRCFile,interface_crc);
  776. {$endif Test_Double_checksum_write}
  777. if crc_index<crc_array_size then
  778. inc(crc_index);
  779. end
  780. else
  781. begin
  782. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  783. (crc_test^[crcindex]<>interface_crc) then
  784. Do_comment(V_Warning,'CRC changed');
  785. {$ifdef Test_Double_checksum_write}
  786. Writeln(CRCFile,interface_crc);
  787. {$endif Test_Double_checksum_write}
  788. inc(crcindex);
  789. end;
  790. {$endif def Test_Double_checksum}
  791. end;
  792. end;
  793. if not crc_only then
  794. writedata(b,len);
  795. inc(entryidx,len);
  796. end;
  797. procedure tppufile.putbyte(b:byte);
  798. begin
  799. writedata(b,1);
  800. inc(entryidx);
  801. end;
  802. procedure tppufile.putword(w:word);
  803. begin
  804. if change_endian then
  805. w:=swap(w);
  806. putdata(w,2);
  807. end;
  808. procedure tppufile.putlongint(l:longint);
  809. begin
  810. if change_endian then
  811. { someone added swap(l : longint) in system unit
  812. this broke the following code !! }
  813. l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
  814. putdata(l,4);
  815. end;
  816. procedure tppufile.putreal(d:ppureal);
  817. begin
  818. putdata(d,sizeof(ppureal));
  819. end;
  820. procedure tppufile.putstring(s:string);
  821. begin
  822. putdata(s,length(s)+1);
  823. end;
  824. procedure tppufile.putsmallset(var b);
  825. begin
  826. putdata(b,4);
  827. end;
  828. procedure tppufile.putnormalset(var b);
  829. begin
  830. putdata(b,32);
  831. end;
  832. procedure tppufile.tempclose;
  833. var
  834. i : word;
  835. begin
  836. if not closed then
  837. begin
  838. closepos:=filepos(f);
  839. {$I-}
  840. system.close(f);
  841. {$I+}
  842. i:=ioresult;
  843. closed:=true;
  844. tempclosed:=true;
  845. end;
  846. end;
  847. function tppufile.tempopen:boolean;
  848. var
  849. ofm : byte;
  850. begin
  851. tempopen:=false;
  852. if not closed or not tempclosed then
  853. exit;
  854. ofm:=filemode;
  855. filemode:=0;
  856. {$I-}
  857. reset(f,1);
  858. {$I+}
  859. filemode:=ofm;
  860. if ioresult<>0 then
  861. exit;
  862. closed:=false;
  863. tempclosed:=false;
  864. { restore state }
  865. seek(f,closepos);
  866. tempopen:=true;
  867. end;
  868. end.
  869. {
  870. $Log$
  871. Revision 1.42 1999-08-31 15:47:56 pierre
  872. + startup conditionnals stored in PPU file for debug info
  873. Revision 1.41 1999/08/30 16:21:40 pierre
  874. * tempclosing of ppufiles under dos was wrong
  875. Revision 1.40 1999/08/27 10:48:40 pierre
  876. + tppufile.tempclose and tempopen added
  877. * some changes so that nothing is writtedn to disk while
  878. calculating CRC only
  879. Revision 1.39 1999/08/24 12:01:36 michael
  880. + changes for resourcestrings
  881. Revision 1.38 1999/08/15 10:47:48 peter
  882. + normalset,smallset writing
  883. Revision 1.37 1999/08/02 23:13:20 florian
  884. * more changes to compile for the Alpha
  885. Revision 1.36 1999/07/23 16:05:25 peter
  886. * alignment is now saved in the symtable
  887. * C alignment added for records
  888. * PPU version increased to solve .12 <-> .13 probs
  889. Revision 1.35 1999/07/05 16:21:30 peter
  890. * fixed linking for units without linking necessary
  891. Revision 1.34 1999/07/03 00:29:57 peter
  892. * new link writing to the ppu, one .ppu is needed for all link types,
  893. static (.o) is now always created also when smartlinking is used
  894. Revision 1.33 1999/05/13 21:59:36 peter
  895. * removed oldppu code
  896. * warning if objpas is loaded from uses
  897. * first things for new deref writing
  898. Revision 1.32 1999/05/05 09:19:15 florian
  899. * more fixes to get it with delphi running
  900. Revision 1.31 1999/05/04 21:44:59 florian
  901. * changes to compile it with Delphi 4.0
  902. Revision 1.30 1999/04/26 18:30:00 peter
  903. * farpointerdef moved into pointerdef.is_far
  904. Revision 1.29 1999/04/26 13:31:41 peter
  905. * release storenumber,double_checksum
  906. Revision 1.28 1999/04/26 09:33:07 peter
  907. * header extended to 40 bytes so there is room for future
  908. Revision 1.27 1999/04/17 13:16:20 peter
  909. * fixes for storenumber
  910. Revision 1.26 1999/04/07 15:39:31 pierre
  911. + double_checksum code added
  912. Revision 1.25 1999/03/02 13:49:18 peter
  913. * renamed loadunit_int -> loadunit
  914. Revision 1.24 1999/02/22 13:07:00 pierre
  915. + -b and -bl options work !
  916. + cs_local_browser ($L+) is disabled if cs_browser ($Y+)
  917. is not enabled when quitting global section
  918. * local vars and procedures are not yet stored into PPU
  919. Revision 1.23 1999/02/16 00:48:24 peter
  920. * save in the ppu if linked with obj file instead of using the
  921. library flag, so the .inc files are also checked
  922. Revision 1.22 1999/02/05 08:54:29 pierre
  923. + linkofiles splitted inot linkofiles and linkunitfiles
  924. because linkofiles must be stored with directory
  925. to enabled linking of different objects with same name
  926. in a different directory
  927. Revision 1.21 1998/12/30 22:15:50 peter
  928. + farpointer type
  929. * absolutesym now also stores if its far
  930. Revision 1.20 1998/11/30 16:34:45 pierre
  931. * corrected problems with rangecheck
  932. + added needed code for no rangecheck in CRC32 functions in ppu unit
  933. * enumdef lso need its rangenr reset to zero
  934. when calling reset_global_defs
  935. Revision 1.19 1998/11/16 15:41:42 peter
  936. * tp7 didn't like my ifopt H+ :(
  937. Revision 1.18 1998/11/16 12:18:03 peter
  938. * H+ fixes
  939. Revision 1.17 1998/10/14 10:45:08 pierre
  940. * ppu problems for m68k fixed (at least in cross compiling)
  941. * one last memory leak for sysamiga fixed
  942. * the amiga RTL compiles now completely !!
  943. Revision 1.16 1998/09/24 23:49:14 peter
  944. + aktmodeswitches
  945. Revision 1.15 1998/09/23 15:39:10 pierre
  946. * browser bugfixes
  947. was adding a reference when looking for the symbol
  948. if -bSYM_NAME was used
  949. Revision 1.14 1998/09/21 10:00:07 peter
  950. * store number of defs in ppu file
  951. Revision 1.13 1998/09/21 08:45:18 pierre
  952. + added vmt_offset in tobjectdef.write for fututre use
  953. (first steps to have objects without vmt if no virtual !!)
  954. + added fpu_used field for tabstractprocdef :
  955. sets this level to 2 if the functions return with value in FPU
  956. (is then set to correct value at parsing of implementation)
  957. THIS MIGHT refuse some code with FPU expression too complex
  958. that were accepted before and even in some cases
  959. that don't overflow in fact
  960. ( like if f : float; is a forward that finally in implementation
  961. only uses one fpu register !!)
  962. Nevertheless I think that it will improve security on
  963. FPU operations !!
  964. * most other changes only for UseBrowser code
  965. (added symtable references for record and objects)
  966. local switch for refs to args and local of each function
  967. (static symtable still missing)
  968. UseBrowser still not stable and probably broken by
  969. the definition hash array !!
  970. Revision 1.12 1998/09/18 08:01:37 pierre
  971. + improvement on the usebrowser part
  972. (does not work correctly for now)
  973. Revision 1.11 1998/09/11 15:16:47 peter
  974. * merge fixes
  975. Revision 1.10.2.1 1998/09/11 15:15:04 peter
  976. * fixed not in [] bug
  977. Revision 1.10 1998/08/31 12:26:30 peter
  978. * m68k and palmos updates from surebugfixes
  979. Revision 1.9 1998/08/17 09:17:51 peter
  980. * static/shared linking updates
  981. Revision 1.8 1998/08/11 15:31:40 peter
  982. * write extended to ppu file
  983. * new version 0.99.7
  984. Revision 1.7 1998/06/25 10:51:01 pierre
  985. * removed a remaining ifndef NEWPPU
  986. replaced by ifdef OLDPPU
  987. * added uf_finalize to ppu unit
  988. Revision 1.6 1998/06/16 08:56:26 peter
  989. + targetcpu
  990. * cleaner pmodules for newppu
  991. Revision 1.5 1998/06/13 00:10:12 peter
  992. * working browser and newppu
  993. * some small fixes against crashes which occured in bp7 (but not in
  994. fpc?!)
  995. Revision 1.4 1998/06/09 16:01:48 pierre
  996. + added procedure directive parsing for procvars
  997. (accepted are popstack cdecl and pascal)
  998. + added C vars with the following syntax
  999. var C calias 'true_c_name';(can be followed by external)
  1000. reason is that you must add the Cprefix
  1001. which is target dependent
  1002. Revision 1.3 1998/05/28 14:40:26 peter
  1003. * fixes for newppu, remake3 works now with it
  1004. Revision 1.2 1998/05/27 19:45:08 peter
  1005. * symtable.pas splitted into includefiles
  1006. * symtable adapted for $ifdef NEWPPU
  1007. Revision 1.1 1998/05/12 10:56:07 peter
  1008. + the ppufile object unit
  1009. }