ppu.pas 22 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031
  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. 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]:='6';
  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.35 1999-07-05 16:21:30 peter
  769. * fixed linking for units without linking necessary
  770. Revision 1.34 1999/07/03 00:29:57 peter
  771. * new link writing to the ppu, one .ppu is needed for all link types,
  772. static (.o) is now always created also when smartlinking is used
  773. Revision 1.33 1999/05/13 21:59:36 peter
  774. * removed oldppu code
  775. * warning if objpas is loaded from uses
  776. * first things for new deref writing
  777. Revision 1.32 1999/05/05 09:19:15 florian
  778. * more fixes to get it with delphi running
  779. Revision 1.31 1999/05/04 21:44:59 florian
  780. * changes to compile it with Delphi 4.0
  781. Revision 1.30 1999/04/26 18:30:00 peter
  782. * farpointerdef moved into pointerdef.is_far
  783. Revision 1.29 1999/04/26 13:31:41 peter
  784. * release storenumber,double_checksum
  785. Revision 1.28 1999/04/26 09:33:07 peter
  786. * header extended to 40 bytes so there is room for future
  787. Revision 1.27 1999/04/17 13:16:20 peter
  788. * fixes for storenumber
  789. Revision 1.26 1999/04/07 15:39:31 pierre
  790. + double_checksum code added
  791. Revision 1.25 1999/03/02 13:49:18 peter
  792. * renamed loadunit_int -> loadunit
  793. Revision 1.24 1999/02/22 13:07:00 pierre
  794. + -b and -bl options work !
  795. + cs_local_browser ($L+) is disabled if cs_browser ($Y+)
  796. is not enabled when quitting global section
  797. * local vars and procedures are not yet stored into PPU
  798. Revision 1.23 1999/02/16 00:48:24 peter
  799. * save in the ppu if linked with obj file instead of using the
  800. library flag, so the .inc files are also checked
  801. Revision 1.22 1999/02/05 08:54:29 pierre
  802. + linkofiles splitted inot linkofiles and linkunitfiles
  803. because linkofiles must be stored with directory
  804. to enabled linking of different objects with same name
  805. in a different directory
  806. Revision 1.21 1998/12/30 22:15:50 peter
  807. + farpointer type
  808. * absolutesym now also stores if its far
  809. Revision 1.20 1998/11/30 16:34:45 pierre
  810. * corrected problems with rangecheck
  811. + added needed code for no rangecheck in CRC32 functions in ppu unit
  812. * enumdef lso need its rangenr reset to zero
  813. when calling reset_global_defs
  814. Revision 1.19 1998/11/16 15:41:42 peter
  815. * tp7 didn't like my ifopt H+ :(
  816. Revision 1.18 1998/11/16 12:18:03 peter
  817. * H+ fixes
  818. Revision 1.17 1998/10/14 10:45:08 pierre
  819. * ppu problems for m68k fixed (at least in cross compiling)
  820. * one last memory leak for sysamiga fixed
  821. * the amiga RTL compiles now completely !!
  822. Revision 1.16 1998/09/24 23:49:14 peter
  823. + aktmodeswitches
  824. Revision 1.15 1998/09/23 15:39:10 pierre
  825. * browser bugfixes
  826. was adding a reference when looking for the symbol
  827. if -bSYM_NAME was used
  828. Revision 1.14 1998/09/21 10:00:07 peter
  829. * store number of defs in ppu file
  830. Revision 1.13 1998/09/21 08:45:18 pierre
  831. + added vmt_offset in tobjectdef.write for fututre use
  832. (first steps to have objects without vmt if no virtual !!)
  833. + added fpu_used field for tabstractprocdef :
  834. sets this level to 2 if the functions return with value in FPU
  835. (is then set to correct value at parsing of implementation)
  836. THIS MIGHT refuse some code with FPU expression too complex
  837. that were accepted before and even in some cases
  838. that don't overflow in fact
  839. ( like if f : float; is a forward that finally in implementation
  840. only uses one fpu register !!)
  841. Nevertheless I think that it will improve security on
  842. FPU operations !!
  843. * most other changes only for UseBrowser code
  844. (added symtable references for record and objects)
  845. local switch for refs to args and local of each function
  846. (static symtable still missing)
  847. UseBrowser still not stable and probably broken by
  848. the definition hash array !!
  849. Revision 1.12 1998/09/18 08:01:37 pierre
  850. + improvement on the usebrowser part
  851. (does not work correctly for now)
  852. Revision 1.11 1998/09/11 15:16:47 peter
  853. * merge fixes
  854. Revision 1.10.2.1 1998/09/11 15:15:04 peter
  855. * fixed not in [] bug
  856. Revision 1.10 1998/08/31 12:26:30 peter
  857. * m68k and palmos updates from surebugfixes
  858. Revision 1.9 1998/08/17 09:17:51 peter
  859. * static/shared linking updates
  860. Revision 1.8 1998/08/11 15:31:40 peter
  861. * write extended to ppu file
  862. * new version 0.99.7
  863. Revision 1.7 1998/06/25 10:51:01 pierre
  864. * removed a remaining ifndef NEWPPU
  865. replaced by ifdef OLDPPU
  866. * added uf_finalize to ppu unit
  867. Revision 1.6 1998/06/16 08:56:26 peter
  868. + targetcpu
  869. * cleaner pmodules for newppu
  870. Revision 1.5 1998/06/13 00:10:12 peter
  871. * working browser and newppu
  872. * some small fixes against crashes which occured in bp7 (but not in
  873. fpc?!)
  874. Revision 1.4 1998/06/09 16:01:48 pierre
  875. + added procedure directive parsing for procvars
  876. (accepted are popstack cdecl and pascal)
  877. + added C vars with the following syntax
  878. var C calias 'true_c_name';(can be followed by external)
  879. reason is that you must add the Cprefix
  880. which is target dependent
  881. Revision 1.3 1998/05/28 14:40:26 peter
  882. * fixes for newppu, remake3 works now with it
  883. Revision 1.2 1998/05/27 19:45:08 peter
  884. * symtable.pas splitted into includefiles
  885. * symtable adapted for $ifdef NEWPPU
  886. Revision 1.1 1998/05/12 10:56:07 peter
  887. + the ppufile object unit
  888. }