ppu.pas 23 KB

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