ppu.pas 22 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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. { Also write the ppu if only crc if done, this can be used with ppudump to
  24. see the differences between the intf and implementation }
  25. { define INTFPPU}
  26. {$define ORDERSOURCES}
  27. {$ifdef Test_Double_checksum}
  28. var
  29. CRCFile : text;
  30. const
  31. CRC_array_Size = 200000;
  32. type
  33. tcrc_array = array[0..crc_array_size] of longint;
  34. pcrc_array = ^tcrc_array;
  35. {$endif Test_Double_checksum}
  36. const
  37. {$ifdef newcg}
  38. {$ifdef ORDERSOURCES}
  39. CurrentPPUVersion=103;
  40. {$else ORDERSOURCES}
  41. CurrentPPUVersion=102;
  42. {$endif ORDERSOURCES}
  43. {$else newcg}
  44. {$ifdef ORDERSOURCES}
  45. CurrentPPUVersion=21;
  46. {$else ORDERSOURCES}
  47. CurrentPPUVersion=20;
  48. {$endif ORDERSOURCES}
  49. {$endif newcg}
  50. { buffer sizes }
  51. maxentrysize = 1024;
  52. {$ifdef TP}
  53. ppubufsize = 1024;
  54. {$else}
  55. ppubufsize = 16384;
  56. {$endif}
  57. {ppu entries}
  58. mainentryid = 1;
  59. subentryid = 2;
  60. {special}
  61. iberror = 0;
  62. ibstartdefs = 248;
  63. ibenddefs = 249;
  64. ibstartsyms = 250;
  65. ibendsyms = 251;
  66. ibendinterface = 252;
  67. ibendimplementation = 253;
  68. ibendbrowser = 254;
  69. ibend = 255;
  70. {general}
  71. ibmodulename = 1;
  72. ibsourcefiles = 2;
  73. ibloadunit = 3;
  74. ibinitunit = 4;
  75. iblinkunitofiles = 5;
  76. iblinkunitstaticlibs = 6;
  77. iblinkunitsharedlibs = 7;
  78. iblinkotherofiles = 8;
  79. iblinkotherstaticlibs = 9;
  80. iblinkothersharedlibs = 10;
  81. ibdbxcount = 11;
  82. ibsymref = 12;
  83. ibdefref = 13;
  84. ibendsymtablebrowser = 14;
  85. ibbeginsymtablebrowser = 15;
  86. ibusedmacros = 16;
  87. {syms}
  88. ibtypesym = 20;
  89. ibprocsym = 21;
  90. ibvarsym = 22;
  91. ibconstsym = 23;
  92. ibenumsym = 24;
  93. ibtypedconstsym = 25;
  94. ibabsolutesym = 26;
  95. ibpropertysym = 27;
  96. ibvarsym_C = 28;
  97. ibunitsym = 29; { needed for browser }
  98. iblabelsym = 30;
  99. ibfuncretsym = 31;
  100. ibsyssym = 32;
  101. {definitions}
  102. iborddef = 40;
  103. ibpointerdef = 41;
  104. ibarraydef = 42;
  105. ibprocdef = 43;
  106. ibshortstringdef = 44;
  107. ibrecorddef = 45;
  108. ibfiledef = 46;
  109. ibformaldef = 47;
  110. ibobjectdef = 48;
  111. ibenumdef = 49;
  112. ibsetdef = 50;
  113. ibprocvardef = 51;
  114. ibfloatdef = 52;
  115. ibclassrefdef = 53;
  116. iblongstringdef = 54;
  117. ibansistringdef = 55;
  118. ibwidestringdef = 56;
  119. { unit flags }
  120. uf_init = $1;
  121. uf_finalize = $2;
  122. uf_big_endian = $4;
  123. uf_has_dbx = $8;
  124. uf_has_browser = $10;
  125. uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
  126. uf_smart_linked = $40; { the ppu can be smartlinked }
  127. uf_static_linked = $80; { the ppu can be linked static }
  128. uf_shared_linked = $100; { the ppu can be linked shared }
  129. uf_local_browser = $200;
  130. uf_no_link = $400; { unit has no .o generated, but can still have
  131. external linking! }
  132. uf_has_resources = $800; { unit has resource section }
  133. type
  134. {$ifdef m68k}
  135. ppureal=single;
  136. {$else}
  137. ppureal=extended;
  138. {$endif}
  139. tppuerror=(ppuentrytoobig,ppuentryerror);
  140. tppuheader=packed record { 40 bytes }
  141. id : array[1..3] of char; { = 'PPU' }
  142. ver : array[1..3] of char;
  143. compiler : word;
  144. cpu : word;
  145. target : word;
  146. flags : longint;
  147. size : longint; { size of the ppufile without header }
  148. checksum : longint; { checksum for this ppufile }
  149. interface_checksum : longint;
  150. future : array[0..2] of longint;
  151. end;
  152. tppuentry=packed record
  153. id : byte;
  154. nr : byte;
  155. size : longint;
  156. end;
  157. pppufile=^tppufile;
  158. tppufile=object
  159. f : file;
  160. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  161. error : boolean;
  162. fname : string;
  163. fsize : longint;
  164. header : tppuheader;
  165. size,crc : longint;
  166. {$ifdef Test_Double_checksum}
  167. crcindex : longint;
  168. crc_index : longint;
  169. crcindex2 : longint;
  170. crc_index2 : longint;
  171. crc_test,crc_test2 : pcrc_array;
  172. {$endif def Test_Double_checksum}
  173. interface_crc : longint;
  174. do_interface_crc : boolean;
  175. crc_only : boolean; { used to calculate interface_crc before implementation }
  176. do_crc,
  177. change_endian : boolean;
  178. buf : pchar;
  179. bufstart,
  180. bufsize,
  181. bufidx : longint;
  182. entrybufstart,
  183. entrystart,
  184. entryidx : longint;
  185. entry : tppuentry;
  186. entrytyp : byte;
  187. closed,
  188. tempclosed : boolean;
  189. closepos : longint;
  190. constructor init(fn:string);
  191. destructor done;
  192. procedure flush;
  193. procedure close;
  194. function CheckPPUId:boolean;
  195. function GetPPUVersion:longint;
  196. procedure NewHeader;
  197. procedure NewEntry;
  198. {read}
  199. function open:boolean;
  200. procedure reloadbuf;
  201. procedure readdata(var b;len:longint);
  202. procedure skipdata(len:longint);
  203. function readentry:byte;
  204. function EndOfEntry:boolean;
  205. procedure getdatabuf(var b;len:longint;var result:longint);
  206. procedure getdata(var b;len:longint);
  207. function getbyte:byte;
  208. function getword:word;
  209. function getlongint:longint;
  210. function getreal:ppureal;
  211. function getstring:string;
  212. procedure getnormalset(var b);
  213. procedure getsmallset(var b);
  214. function skipuntilentry(untilb:byte):boolean;
  215. {write}
  216. function create:boolean;
  217. procedure writeheader;
  218. procedure writebuf;
  219. procedure writedata(var b;len:longint);
  220. procedure writeentry(ibnr:byte);
  221. procedure putdata(var b;len:longint);
  222. procedure putbyte(b:byte);
  223. procedure putword(w:word);
  224. procedure putlongint(l:longint);
  225. procedure putreal(d:ppureal);
  226. procedure putstring(s:string);
  227. procedure putnormalset(var b);
  228. procedure putsmallset(var b);
  229. procedure tempclose;
  230. function tempopen:boolean;
  231. end;
  232. implementation
  233. {$ifdef Test_Double_checksum}
  234. uses
  235. comphook;
  236. {$endif def Test_Double_checksum}
  237. {*****************************************************************************
  238. Crc 32
  239. *****************************************************************************}
  240. var
  241. {$ifdef Delphi}
  242. Crc32Tbl : array[0..255] of longword;
  243. {$else Delphi}
  244. Crc32Tbl : array[0..255] of longint;
  245. {$endif Delphi}
  246. procedure MakeCRC32Tbl;
  247. var
  248. {$ifdef Delphi}
  249. crc : longword;
  250. {$else Delphi}
  251. crc : longint;
  252. {$endif Delphi}
  253. i,n : byte;
  254. begin
  255. for i:=0 to 255 do
  256. begin
  257. crc:=i;
  258. for n:=1 to 8 do
  259. if odd(crc) then
  260. crc:=(crc shr 1) xor $edb88320
  261. else
  262. crc:=crc shr 1;
  263. Crc32Tbl[i]:=crc;
  264. end;
  265. end;
  266. {$ifopt R+}
  267. {$define Range_check_on}
  268. {$endif opt R+}
  269. {$R- needed here }
  270. {CRC 32}
  271. Function Crc32(Const HStr:String):longint;
  272. var
  273. i,InitCrc : longint;
  274. begin
  275. if Crc32Tbl[1]=0 then
  276. MakeCrc32Tbl;
  277. InitCrc:=$ffffffff;
  278. for i:=1to Length(Hstr) do
  279. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
  280. Crc32:=InitCrc;
  281. end;
  282. Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
  283. var
  284. i : word;
  285. p : pchar;
  286. begin
  287. if Crc32Tbl[1]=0 then
  288. MakeCrc32Tbl;
  289. p:=@InBuf;
  290. for i:=1 to InLen do
  291. begin
  292. InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
  293. inc(longint(p));
  294. end;
  295. UpdateCrc32:=InitCrc;
  296. end;
  297. Function UpdCrc32(InitCrc:longint;b:byte):longint;
  298. begin
  299. if Crc32Tbl[1]=0 then
  300. MakeCrc32Tbl;
  301. UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
  302. end;
  303. {$ifdef Range_check_on}
  304. {$R+}
  305. {$undef Range_check_on}
  306. {$endif Range_check_on}
  307. {*****************************************************************************
  308. TPPUFile
  309. *****************************************************************************}
  310. constructor tppufile.init(fn:string);
  311. begin
  312. fname:=fn;
  313. change_endian:=false;
  314. crc_only:=false;
  315. Mode:=0;
  316. NewHeader;
  317. Error:=false;
  318. closed:=true;
  319. tempclosed:=false;
  320. getmem(buf,ppubufsize);
  321. end;
  322. destructor tppufile.done;
  323. begin
  324. close;
  325. if assigned(buf) then
  326. freemem(buf,ppubufsize);
  327. end;
  328. procedure tppufile.flush;
  329. begin
  330. if Mode=2 then
  331. writebuf;
  332. end;
  333. procedure tppufile.close;
  334. begin
  335. if Mode<>0 then
  336. begin
  337. Flush;
  338. {$I-}
  339. system.close(f);
  340. {$I+}
  341. if ioresult<>0 then;
  342. Mode:=0;
  343. closed:=true;
  344. end;
  345. end;
  346. function tppufile.CheckPPUId:boolean;
  347. begin
  348. CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
  349. end;
  350. function tppufile.GetPPUVersion:longint;
  351. var
  352. l : longint;
  353. code : integer;
  354. begin
  355. Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
  356. if code=0 then
  357. GetPPUVersion:=l
  358. else
  359. GetPPUVersion:=0;
  360. end;
  361. procedure tppufile.NewHeader;
  362. var
  363. s : string;
  364. begin
  365. fillchar(header,sizeof(tppuheader),0);
  366. str(currentppuversion,s);
  367. while length(s)<3 do
  368. s:='0'+s;
  369. with header do
  370. begin
  371. Id[1]:='P';
  372. Id[2]:='P';
  373. Id[3]:='U';
  374. Ver[1]:=s[1];
  375. Ver[2]:=s[2];
  376. Ver[3]:=s[3];
  377. end;
  378. end;
  379. {*****************************************************************************
  380. TPPUFile Reading
  381. *****************************************************************************}
  382. function tppufile.open:boolean;
  383. var
  384. ofmode : byte;
  385. {$ifdef delphi}
  386. i : integer;
  387. {$else delphi}
  388. i : word;
  389. {$endif delphi}
  390. begin
  391. open:=false;
  392. assign(f,fname);
  393. ofmode:=filemode;
  394. filemode:=$0;
  395. {$I-}
  396. reset(f,1);
  397. {$I+}
  398. filemode:=ofmode;
  399. if ioresult<>0 then
  400. exit;
  401. closed:=false;
  402. {read ppuheader}
  403. fsize:=filesize(f);
  404. if fsize<sizeof(tppuheader) then
  405. exit;
  406. blockread(f,header,sizeof(tppuheader),i);
  407. {reset buffer}
  408. bufstart:=i;
  409. bufsize:=0;
  410. bufidx:=0;
  411. Mode:=1;
  412. FillChar(entry,sizeof(tppuentry),0);
  413. entryidx:=0;
  414. entrystart:=0;
  415. entrybufstart:=0;
  416. Error:=false;
  417. open:=true;
  418. end;
  419. procedure tppufile.reloadbuf;
  420. {$ifdef TP}
  421. var
  422. i : word;
  423. {$endif}
  424. begin
  425. inc(bufstart,bufsize);
  426. {$ifdef TP}
  427. blockread(f,buf^,ppubufsize,i);
  428. bufsize:=i;
  429. {$else}
  430. blockread(f,buf^,ppubufsize,bufsize);
  431. {$endif}
  432. bufidx:=0;
  433. end;
  434. procedure tppufile.readdata(var b;len:longint);
  435. var
  436. p : pchar;
  437. left,
  438. idx : longint;
  439. begin
  440. p:=pchar(@b);
  441. idx:=0;
  442. while len>0 do
  443. begin
  444. left:=bufsize-bufidx;
  445. if len>left then
  446. begin
  447. move(buf[bufidx],p[idx],left);
  448. dec(len,left);
  449. inc(idx,left);
  450. reloadbuf;
  451. if bufsize=0 then
  452. exit;
  453. end
  454. else
  455. begin
  456. move(buf[bufidx],p[idx],len);
  457. inc(bufidx,len);
  458. exit;
  459. end;
  460. end;
  461. end;
  462. procedure tppufile.skipdata(len:longint);
  463. var
  464. left : longint;
  465. begin
  466. while len>0 do
  467. begin
  468. left:=bufsize-bufidx;
  469. if len>left then
  470. begin
  471. dec(len,left);
  472. reloadbuf;
  473. if bufsize=0 then
  474. exit;
  475. end
  476. else
  477. begin
  478. inc(bufidx,len);
  479. exit;
  480. end;
  481. end;
  482. end;
  483. function tppufile.readentry:byte;
  484. begin
  485. if entryidx<entry.size then
  486. skipdata(entry.size-entryidx);
  487. readdata(entry,sizeof(tppuentry));
  488. entrystart:=bufstart+bufidx;
  489. entryidx:=0;
  490. if not(entry.id in [mainentryid,subentryid]) then
  491. begin
  492. readentry:=iberror;
  493. error:=true;
  494. exit;
  495. end;
  496. readentry:=entry.nr;
  497. end;
  498. function tppufile.endofentry:boolean;
  499. begin
  500. endofentry:=(entryidx>=entry.size);
  501. end;
  502. procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
  503. begin
  504. if entryidx+len>entry.size then
  505. result:=entry.size-entryidx
  506. else
  507. result:=len;
  508. readdata(b,result);
  509. inc(entryidx,result);
  510. end;
  511. procedure tppufile.getdata(var b;len:longint);
  512. begin
  513. if entryidx+len>entry.size then
  514. begin
  515. error:=true;
  516. exit;
  517. end;
  518. readdata(b,len);
  519. inc(entryidx,len);
  520. end;
  521. function tppufile.getbyte:byte;
  522. var
  523. b : byte;
  524. begin
  525. if entryidx+1>entry.size then
  526. begin
  527. error:=true;
  528. getbyte:=0;
  529. exit;
  530. end;
  531. readdata(b,1);
  532. getbyte:=b;
  533. inc(entryidx);
  534. end;
  535. function tppufile.getword:word;
  536. type
  537. pword = ^word;
  538. var
  539. w : word;
  540. begin
  541. if entryidx+2>entry.size then
  542. begin
  543. error:=true;
  544. getword:=0;
  545. exit;
  546. end;
  547. readdata(w,2);
  548. if change_endian then
  549. getword:=swap(w)
  550. else
  551. getword:=w;
  552. inc(entryidx,2);
  553. end;
  554. function tppufile.getlongint:longint;
  555. type
  556. plongint = ^longint;
  557. var
  558. l : longint;
  559. begin
  560. if entryidx+4>entry.size then
  561. begin
  562. error:=true;
  563. getlongint:=0;
  564. exit;
  565. end;
  566. readdata(l,4);
  567. if change_endian then
  568. { someone added swap(l : longint) in system unit
  569. this broke the following code !! }
  570. getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
  571. else
  572. getlongint:=l;
  573. inc(entryidx,4);
  574. end;
  575. function tppufile.getreal:ppureal;
  576. type
  577. pppureal = ^ppureal;
  578. var
  579. d : ppureal;
  580. begin
  581. if entryidx+sizeof(ppureal)>entry.size then
  582. begin
  583. error:=true;
  584. getreal:=0;
  585. exit;
  586. end;
  587. readdata(d,sizeof(ppureal));
  588. getreal:=d;
  589. inc(entryidx,sizeof(ppureal));
  590. end;
  591. function tppufile.getstring:string;
  592. var
  593. s : string;
  594. begin
  595. {$ifndef TP}
  596. {$ifopt H+}
  597. setlength(s,getbyte);
  598. {$else}
  599. s[0]:=chr(getbyte);
  600. {$endif}
  601. {$else}
  602. s[0]:=chr(getbyte);
  603. {$endif}
  604. if entryidx+length(s)>entry.size then
  605. begin
  606. error:=true;
  607. exit;
  608. end;
  609. ReadData(s[1],length(s));
  610. getstring:=s;
  611. inc(entryidx,length(s));
  612. end;
  613. procedure tppufile.getsmallset(var b);
  614. begin
  615. getdata(b,4);
  616. end;
  617. procedure tppufile.getnormalset(var b);
  618. begin
  619. getdata(b,32);
  620. end;
  621. function tppufile.skipuntilentry(untilb:byte):boolean;
  622. var
  623. b : byte;
  624. begin
  625. repeat
  626. b:=readentry;
  627. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  628. skipuntilentry:=(b=untilb);
  629. end;
  630. {*****************************************************************************
  631. TPPUFile Writing
  632. *****************************************************************************}
  633. function tppufile.create:boolean;
  634. begin
  635. create:=false;
  636. {$ifdef INTFPPU}
  637. if crc_only then
  638. begin
  639. fname:=fname+'.intf';
  640. crc_only:=false;
  641. end;
  642. {$endif}
  643. if not crc_only then
  644. begin
  645. assign(f,fname);
  646. {$I-}
  647. rewrite(f,1);
  648. {$I+}
  649. if ioresult<>0 then
  650. exit;
  651. Mode:=2;
  652. {write header for sure}
  653. blockwrite(f,header,sizeof(tppuheader));
  654. end;
  655. bufsize:=ppubufsize;
  656. bufstart:=sizeof(tppuheader);
  657. bufidx:=0;
  658. {reset}
  659. crc:=$ffffffff;
  660. interface_crc:=$ffffffff;
  661. do_interface_crc:=true;
  662. Error:=false;
  663. do_crc:=true;
  664. size:=0;
  665. entrytyp:=mainentryid;
  666. {start}
  667. NewEntry;
  668. create:=true;
  669. end;
  670. procedure tppufile.writeheader;
  671. var
  672. opos : longint;
  673. begin
  674. { flush buffer }
  675. writebuf;
  676. { update size (w/o header!) in the header }
  677. header.size:=bufstart-sizeof(tppuheader);
  678. { write header and restore filepos after it }
  679. opos:=filepos(f);
  680. seek(f,0);
  681. blockwrite(f,header,sizeof(tppuheader));
  682. seek(f,opos);
  683. end;
  684. procedure tppufile.writebuf;
  685. begin
  686. if not crc_only then
  687. blockwrite(f,buf^,bufidx);
  688. inc(bufstart,bufidx);
  689. bufidx:=0;
  690. end;
  691. procedure tppufile.writedata(var b;len:longint);
  692. var
  693. p : pchar;
  694. left,
  695. idx : longint;
  696. begin
  697. if crc_only then
  698. exit;
  699. p:=pchar(@b);
  700. idx:=0;
  701. while len>0 do
  702. begin
  703. left:=bufsize-bufidx;
  704. if len>left then
  705. begin
  706. move(p[idx],buf[bufidx],left);
  707. dec(len,left);
  708. inc(idx,left);
  709. inc(bufidx,left);
  710. writebuf;
  711. end
  712. else
  713. begin
  714. move(p[idx],buf[bufidx],len);
  715. inc(bufidx,len);
  716. exit;
  717. end;
  718. end;
  719. end;
  720. procedure tppufile.NewEntry;
  721. begin
  722. with entry do
  723. begin
  724. id:=entrytyp;
  725. nr:=ibend;
  726. size:=0;
  727. end;
  728. {Reset Entry State}
  729. entryidx:=0;
  730. entrybufstart:=bufstart;
  731. entrystart:=bufstart+bufidx;
  732. {Alloc in buffer}
  733. writedata(entry,sizeof(tppuentry));
  734. end;
  735. procedure tppufile.writeentry(ibnr:byte);
  736. var
  737. opos : longint;
  738. begin
  739. {create entry}
  740. entry.id:=entrytyp;
  741. entry.nr:=ibnr;
  742. entry.size:=entryidx;
  743. {it's already been sent to disk ?}
  744. if entrybufstart<>bufstart then
  745. begin
  746. if not crc_only then
  747. begin
  748. {flush to be sure}
  749. WriteBuf;
  750. {write entry}
  751. opos:=filepos(f);
  752. seek(f,entrystart);
  753. blockwrite(f,entry,sizeof(tppuentry));
  754. seek(f,opos);
  755. end;
  756. entrybufstart:=bufstart;
  757. end
  758. else
  759. move(entry,buf[entrystart-bufstart],sizeof(entry));
  760. {Add New Entry, which is ibend by default}
  761. entrystart:=bufstart+bufidx; {next entry position}
  762. NewEntry;
  763. end;
  764. procedure tppufile.putdata(var b;len:longint);
  765. begin
  766. if do_crc then
  767. begin
  768. crc:=UpdateCrc32(crc,b,len);
  769. {$ifdef Test_Double_checksum}
  770. if crc_only then
  771. begin
  772. crc_test2^[crc_index2]:=crc;
  773. {$ifdef Test_Double_checksum_write}
  774. Writeln(CRCFile,crc);
  775. {$endif Test_Double_checksum_write}
  776. if crc_index2<crc_array_size then
  777. inc(crc_index2);
  778. end
  779. else
  780. begin
  781. if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
  782. (crc_test2^[crcindex2]<>crc) then
  783. Do_comment(V_Warning,'impl CRC changed');
  784. {$ifdef Test_Double_checksum_write}
  785. Writeln(CRCFile,crc);
  786. {$endif Test_Double_checksum_write}
  787. inc(crcindex2);
  788. end;
  789. {$endif def Test_Double_checksum}
  790. if do_interface_crc then
  791. begin
  792. interface_crc:=UpdateCrc32(interface_crc,b,len);
  793. {$ifdef Test_Double_checksum}
  794. if crc_only then
  795. begin
  796. crc_test^[crc_index]:=interface_crc;
  797. {$ifdef Test_Double_checksum_write}
  798. Writeln(CRCFile,interface_crc);
  799. {$endif Test_Double_checksum_write}
  800. if crc_index<crc_array_size then
  801. inc(crc_index);
  802. end
  803. else
  804. begin
  805. if (crcindex<crc_array_size) and (crcindex<crc_index) and
  806. (crc_test^[crcindex]<>interface_crc) then
  807. Do_comment(V_Warning,'CRC changed');
  808. {$ifdef Test_Double_checksum_write}
  809. Writeln(CRCFile,interface_crc);
  810. {$endif Test_Double_checksum_write}
  811. inc(crcindex);
  812. end;
  813. {$endif def Test_Double_checksum}
  814. end;
  815. end;
  816. if not crc_only then
  817. writedata(b,len);
  818. inc(entryidx,len);
  819. end;
  820. procedure tppufile.putbyte(b:byte);
  821. begin
  822. putdata(b,1);
  823. { inc(entryidx);}
  824. end;
  825. procedure tppufile.putword(w:word);
  826. begin
  827. if change_endian then
  828. w:=swap(w);
  829. putdata(w,2);
  830. end;
  831. procedure tppufile.putlongint(l:longint);
  832. begin
  833. if change_endian then
  834. { someone added swap(l : longint) in system unit
  835. this broke the following code !! }
  836. l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
  837. putdata(l,4);
  838. end;
  839. procedure tppufile.putreal(d:ppureal);
  840. begin
  841. putdata(d,sizeof(ppureal));
  842. end;
  843. procedure tppufile.putstring(s:string);
  844. begin
  845. putdata(s,length(s)+1);
  846. end;
  847. procedure tppufile.putsmallset(var b);
  848. begin
  849. putdata(b,4);
  850. end;
  851. procedure tppufile.putnormalset(var b);
  852. begin
  853. putdata(b,32);
  854. end;
  855. procedure tppufile.tempclose;
  856. begin
  857. if not closed then
  858. begin
  859. closepos:=filepos(f);
  860. {$I-}
  861. system.close(f);
  862. {$I+}
  863. if ioresult<>0 then;
  864. closed:=true;
  865. tempclosed:=true;
  866. end;
  867. end;
  868. function tppufile.tempopen:boolean;
  869. var
  870. ofm : byte;
  871. begin
  872. tempopen:=false;
  873. if not closed or not tempclosed then
  874. exit;
  875. ofm:=filemode;
  876. filemode:=0;
  877. {$I-}
  878. reset(f,1);
  879. {$I+}
  880. filemode:=ofm;
  881. if ioresult<>0 then
  882. exit;
  883. closed:=false;
  884. tempclosed:=false;
  885. { restore state }
  886. seek(f,closepos);
  887. tempopen:=true;
  888. end;
  889. end.
  890. {
  891. $Log$
  892. Revision 1.57 2000-05-11 06:54:29 florian
  893. * fixed some vmt problems, especially related to overloaded methods
  894. in objects/classes
  895. Revision 1.56 2000/02/29 21:58:31 pierre
  896. * ORDERSOURCES released
  897. Revision 1.55 2000/02/09 13:22:59 peter
  898. * log truncated
  899. Revision 1.54 2000/01/07 01:14:30 peter
  900. * updated copyright to 2000
  901. Revision 1.53 1999/12/02 11:29:07 peter
  902. * INFTPPU define to write the ppu of the interface to .ppu.intf
  903. Revision 1.52 1999/11/30 10:40:45 peter
  904. + ttype, tsymlist
  905. Revision 1.51 1999/11/23 09:42:38 peter
  906. * makefile updates to work with new fpcmake
  907. Revision 1.50 1999/11/21 01:42:37 pierre
  908. * Nextoverloading ordering fix
  909. Revision 1.49 1999/11/18 15:34:48 pierre
  910. * Notes/Hints for local syms changed to
  911. Set_varstate function
  912. Revision 1.48 1999/11/17 17:05:02 pierre
  913. * Notes/hints changes
  914. Revision 1.47 1999/11/06 14:34:23 peter
  915. * truncated log to 20 revs
  916. Revision 1.46 1999/09/17 09:14:56 peter
  917. * ppu header writting now uses currentppuversion
  918. Revision 1.45 1999/09/16 13:27:08 pierre
  919. + error if PPU modulename is different from what is searched
  920. (8+3 limitations!)
  921. + cond ORDERSOURCES to allow recompilation of FP
  922. if symppu.inc is changed (need PPUversion change!)
  923. Revision 1.44 1999/09/16 11:34:58 pierre
  924. * typo correction
  925. Revision 1.43 1999/09/10 18:48:09 florian
  926. * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
  927. * most things for stored properties fixed
  928. Revision 1.42 1999/08/31 15:47:56 pierre
  929. + startup conditionals stored in PPU file for debug info
  930. Revision 1.41 1999/08/30 16:21:40 pierre
  931. * tempclosing of ppufiles under dos was wrong
  932. Revision 1.40 1999/08/27 10:48:40 pierre
  933. + tppufile.tempclose and tempopen added
  934. * some changes so that nothing is writtedn to disk while
  935. calculating CRC only
  936. Revision 1.39 1999/08/24 12:01:36 michael
  937. + changes for resourcestrings
  938. Revision 1.38 1999/08/15 10:47:48 peter
  939. + normalset,smallset writing
  940. Revision 1.37 1999/08/02 23:13:20 florian
  941. * more changes to compile for the Alpha
  942. Revision 1.36 1999/07/23 16:05:25 peter
  943. * alignment is now saved in the symtable
  944. * C alignment added for records
  945. * PPU version increased to solve .12 <-> .13 probs
  946. }