ppu.pas 22 KB

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