ppu.pas 22 KB

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