ppu.pas 22 KB

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