ppu.pas 23 KB

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