ppu.pas 23 KB

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