ppu.pas 23 KB

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