ppu.pas 26 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177
  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.5 1999-08-31 16:06:47 pierre
  872. updated to v1.42 of compiler unit
  873. Revision 1.42 1999/08/31 15:47:56 pierre
  874. + startup conditionnals stored in PPU file for debug info
  875. Revision 1.41 1999/08/30 16:21:40 pierre
  876. * tempclosing of ppufiles under dos was wrong
  877. Revision 1.40 1999/08/27 10:48:40 pierre
  878. + tppufile.tempclose and tempopen added
  879. * some changes so that nothing is writtedn to disk while
  880. calculating CRC only
  881. Revision 1.39 1999/08/24 12:01:36 michael
  882. + changes for resourcestrings
  883. Revision 1.38 1999/08/15 10:47:48 peter
  884. + normalset,smallset writing
  885. Revision 1.4 1999/08/15 10:47:12 peter
  886. * updates for new options
  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. }