entfile.pas 28 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383
  1. {
  2. Copyright (c) 1998-2013 by Free Pascal development team
  3. Routines to read/write entry based files (ppu, pcp)
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit entfile;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. systems,globtype,constexp,cstreams;
  22. const
  23. { buffer sizes }
  24. maxentrysize = 1024;
  25. entryfilebufsize = 16384;
  26. {ppu entries}
  27. mainentryid = 1;
  28. subentryid = 2;
  29. {special}
  30. iberror = 0;
  31. ibextraheader = 242;
  32. ibpputable = 243;
  33. ibstartrequireds = 244;
  34. ibendrequireds = 245;
  35. ibstartcontained = 246;
  36. ibendcontained = 247;
  37. ibstartdefs = 248;
  38. ibenddefs = 249;
  39. ibstartsyms = 250;
  40. ibendsyms = 251;
  41. ibendinterface = 252;
  42. ibendimplementation = 253;
  43. // ibendbrowser = 254;
  44. ibend = 255;
  45. {general}
  46. ibmodulename = 1;
  47. ibsourcefiles = 2;
  48. ibloadunit = 3;
  49. ibinitunit = 4;
  50. iblinkunitofiles = 5;
  51. iblinkunitstaticlibs = 6;
  52. iblinkunitsharedlibs = 7;
  53. iblinkotherofiles = 8;
  54. iblinkotherstaticlibs = 9;
  55. iblinkothersharedlibs = 10;
  56. ibImportSymbols = 11;
  57. ibsymref = 12;
  58. ibdefref = 13;
  59. ibfeatures = 14;
  60. {$IFDEF MACRO_DIFF_HINT}
  61. ibusedmacros = 16;
  62. {$ENDIF}
  63. ibderefdata = 17;
  64. ibexportedmacros = 18;
  65. ibderefmap = 19;
  66. {syms}
  67. ibtypesym = 20;
  68. ibprocsym = 21;
  69. ibstaticvarsym = 22;
  70. ibconstsym = 23;
  71. ibenumsym = 24;
  72. // ibtypedconstsym = 25;
  73. ibabsolutevarsym = 26;
  74. ibpropertysym = 27;
  75. ibfieldvarsym = 28;
  76. ibunitsym = 29;
  77. iblabelsym = 30;
  78. ibsyssym = 31;
  79. ibnamespacesym = 32;
  80. iblocalvarsym = 33;
  81. ibparavarsym = 34;
  82. ibmacrosym = 35;
  83. {definitions}
  84. iborddef = 40;
  85. ibpointerdef = 41;
  86. ibarraydef = 42;
  87. ibprocdef = 43;
  88. ibshortstringdef = 44;
  89. ibrecorddef = 45;
  90. ibfiledef = 46;
  91. ibformaldef = 47;
  92. ibobjectdef = 48;
  93. ibenumdef = 49;
  94. ibsetdef = 50;
  95. ibprocvardef = 51;
  96. ibfloatdef = 52;
  97. ibclassrefdef = 53;
  98. iblongstringdef = 54;
  99. ibansistringdef = 55;
  100. ibwidestringdef = 56;
  101. ibvariantdef = 57;
  102. ibundefineddef = 58;
  103. ibunicodestringdef = 59;
  104. {implementation/ObjData}
  105. ibnodetree = 80;
  106. ibasmsymbols = 81;
  107. ibresources = 82;
  108. ibcreatedobjtypes = 83;
  109. ibwpofile = 84;
  110. ibmoduleoptions = 85;
  111. ibunitimportsyms = 86;
  112. ibmainname = 90;
  113. ibsymtableoptions = 91;
  114. ibrecsymtableoptions = 91;
  115. ibpackagefiles = 92;
  116. ibpackagename = 93;
  117. { target-specific things }
  118. iblinkotherframeworks = 100;
  119. ibjvmnamespace = 101;
  120. {$ifdef generic_cpu}
  121. { We need to use the correct size of aint and pint for
  122. the target CPU }
  123. const
  124. CpuAddrBitSize : array[tsystemcpu] of longint =
  125. (
  126. { 0 } 32 {'none'},
  127. { 1 } 32 {'i386'},
  128. { 2 } 32 {'m68k'},
  129. { 3 } 32 {'alpha'},
  130. { 4 } 32 {'powerpc'},
  131. { 5 } 32 {'sparc'},
  132. { 6 } 32 {'vis'},
  133. { 7 } 64 {'ia64'},
  134. { 8 } 64 {'x86_64'},
  135. { 9 } 32 {'mipseb'},
  136. { 10 } 32 {'arm'},
  137. { 11 } 64 {'powerpc64'},
  138. { 12 } 16 {'avr'},
  139. { 13 } 32 {'mipsel'},
  140. { 14 } 32 {'jvm'},
  141. { 15 } 16 {'i8086'},
  142. { 16 } 64 {'aarch64'},
  143. { 17 } 32 {'wasm'},
  144. { 18 } 64 {'sparc64'},
  145. { 19 } 32 {'riscv32'},
  146. { 20 } 64 {'riscv64'}
  147. );
  148. CpuAluBitSize : array[tsystemcpu] of longint =
  149. (
  150. { 0 } 32 {'none'},
  151. { 1 } 32 {'i386'},
  152. { 2 } 32 {'m68k'},
  153. { 3 } 32 {'alpha'},
  154. { 4 } 32 {'powerpc'},
  155. { 5 } 32 {'sparc'},
  156. { 6 } 32 {'vis'},
  157. { 7 } 64 {'ia64'},
  158. { 8 } 64 {'x86_64'},
  159. { 9 } 32 {'mipseb'},
  160. { 10 } 32 {'arm'},
  161. { 11 } 64 {'powerpc64'},
  162. { 12 } 8 {'avr'},
  163. { 13 } 32 {'mipsel'},
  164. { 14 } 64 {'jvm'},
  165. { 15 } 16 {'i8086'},
  166. { 16 } 64 {'aarch64'},
  167. { 17 } 64 {'wasm'},
  168. { 18 } 64 {'sparc64'},
  169. { 19 } 32 {'riscv32'},
  170. { 20 } 64 {'riscv64'}
  171. );
  172. {$endif generic_cpu}
  173. type
  174. { bestreal is defined based on the target architecture }
  175. entryreal=bestreal;
  176. { common part of the header for all kinds of entry files }
  177. tentryheader=record
  178. id : array[1..3] of char;
  179. ver : array[1..3] of char;
  180. compiler : word;
  181. cpu : word;
  182. target : word;
  183. flags : dword;
  184. size : dword; { size of the ppufile without header }
  185. end;
  186. pentryheader=^tentryheader;
  187. tentry=packed record
  188. size : longint;
  189. id : byte;
  190. nr : byte;
  191. end;
  192. tentryfile=class
  193. private
  194. function getposition:longint;
  195. procedure setposition(value:longint);
  196. protected
  197. buf : pchar;
  198. bufstart,
  199. bufsize,
  200. bufidx : integer;
  201. entrybufstart,
  202. entrystart,
  203. entryidx : integer;
  204. entry : tentry;
  205. closed,
  206. tempclosed : boolean;
  207. closepos : integer;
  208. protected
  209. f : TCStream;
  210. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  211. fisfile : boolean;
  212. fname : string;
  213. fsize : integer;
  214. procedure newheader;virtual;abstract;
  215. function readheader:longint;virtual;abstract;
  216. function outputallowed:boolean;virtual;
  217. procedure resetfile;virtual;abstract;
  218. function getheadersize:longint;virtual;abstract;
  219. function getheaderaddr:pentryheader;virtual;abstract;
  220. procedure RaiseAssertion(Code: Longint); virtual;
  221. public
  222. entrytyp : byte;
  223. size : integer;
  224. change_endian : boolean; { Used in ppudump util }
  225. {$ifdef generic_cpu}
  226. has_more,
  227. {$endif not generic_cpu}
  228. error : boolean;
  229. constructor create(const fn:string);
  230. destructor destroy;override;
  231. function getversion:integer;
  232. procedure flush;
  233. procedure closefile;virtual;
  234. procedure newentry;
  235. property position:longint read getposition write setposition;
  236. { Warning: don't keep the stream open during a tempclose! }
  237. function substream(ofs,len:longint):TCStream;
  238. { Warning: don't use the put* or write* functions anymore when writing through this }
  239. property stream:TCStream read f;
  240. {read}
  241. function openfile:boolean;
  242. function openstream(strm:TCStream):boolean;
  243. procedure reloadbuf;
  244. procedure readdata(out b;len:integer);
  245. procedure skipdata(len:integer);
  246. function readentry:byte;
  247. function EndOfEntry:boolean;
  248. function entrysize:longint;
  249. function entryleft:longint;
  250. procedure getdatabuf(out b;len:integer;out res:integer);
  251. procedure getdata(out b;len:integer);
  252. function getbyte:byte;
  253. function getword:word;
  254. function getdword:dword;
  255. function getlongint:longint;
  256. function getint64:int64;
  257. function getqword:qword;
  258. function getaint:{$ifdef generic_cpu}int64{$else}aint{$endif};
  259. function getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$endif};
  260. function getpuint:{$ifdef generic_cpu}qword{$else}puint{$endif};
  261. function getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$endif};
  262. function getaword:{$ifdef generic_cpu}qword{$else}aword{$endif};
  263. function getreal:entryreal;
  264. function getrealsize(sizeofreal : longint):entryreal;
  265. function getboolean:boolean;inline;
  266. function getstring:string;
  267. function getpshortstring:pshortstring;
  268. function getansistring:ansistring;
  269. procedure getnormalset(out b);
  270. procedure getsmallset(out b);
  271. function skipuntilentry(untilb:byte):boolean;
  272. {write}
  273. function createfile:boolean;virtual;
  274. function createstream(strm:TCStream):boolean;
  275. procedure writeheader;virtual;abstract;
  276. procedure writebuf;
  277. procedure writedata(const b;len:integer);
  278. procedure writeentry(ibnr:byte);
  279. procedure putdata(const b;len:integer);virtual;
  280. procedure putbyte(b:byte);
  281. procedure putword(w:word);
  282. procedure putdword(w:dword);
  283. procedure putlongint(l:longint);
  284. procedure putint64(i:int64);
  285. procedure putqword(q:qword);
  286. procedure putaint(i:aint);
  287. procedure putasizeint(i:asizeint);
  288. procedure putpuint(i:puint);
  289. procedure putptruint(v:TConstPtrUInt);
  290. procedure putaword(i:aword);
  291. procedure putreal(d:entryreal);
  292. procedure putboolean(b:boolean);inline;
  293. procedure putstring(const s:string);
  294. procedure putansistring(const s:ansistring);
  295. procedure putnormalset(const b);
  296. procedure putsmallset(const b);
  297. procedure tempclose; // MG: not used, obsolete?
  298. function tempopen:boolean; // MG: not used, obsolete?
  299. end;
  300. implementation
  301. uses
  302. cutils;
  303. function swapendian_entryreal(d:entryreal):entryreal;
  304. type
  305. entryreal_bytes=array[0..sizeof(d)-1] of byte;
  306. var
  307. i:0..sizeof(d)-1;
  308. begin
  309. for i:=low(entryreal_bytes) to high(entryreal_bytes) do
  310. entryreal_bytes(result)[i]:=entryreal_bytes(d)[high(entryreal_bytes)-i];
  311. end;
  312. {*****************************************************************************
  313. tentryfile
  314. *****************************************************************************}
  315. function tentryfile.outputallowed: boolean;
  316. begin
  317. result:=true;
  318. end;
  319. constructor tentryfile.create(const fn:string);
  320. begin
  321. fname:=fn;
  322. fisfile:=false;
  323. change_endian:=false;
  324. mode:=0;
  325. newheader;
  326. error:=false;
  327. closed:=true;
  328. tempclosed:=false;
  329. getmem(buf,entryfilebufsize);
  330. end;
  331. destructor tentryfile.destroy;
  332. begin
  333. closefile;
  334. if assigned(buf) then
  335. freemem(buf,entryfilebufsize);
  336. end;
  337. function tentryfile.getversion:integer;
  338. var
  339. l : integer;
  340. code : integer;
  341. header : pentryheader;
  342. begin
  343. header:=getheaderaddr;
  344. Val(header^.ver[1]+header^.ver[2]+header^.ver[3],l,code);
  345. if code=0 then
  346. result:=l
  347. else
  348. result:=0;
  349. end;
  350. procedure tentryfile.flush;
  351. begin
  352. if mode=2 then
  353. writebuf;
  354. end;
  355. procedure tentryfile.RaiseAssertion(Code: Longint);
  356. begin
  357. { It's down to descendent classes to raise an internal error as desired. [Kit] }
  358. error := true;
  359. end;
  360. procedure tentryfile.closefile;
  361. begin
  362. if mode<>0 then
  363. begin
  364. flush;
  365. if fisfile then
  366. f.Free;
  367. mode:=0;
  368. closed:=true;
  369. end;
  370. end;
  371. procedure tentryfile.setposition(value:longint);
  372. begin
  373. if assigned(f) then
  374. f.Position:=value
  375. else
  376. if tempclosed then
  377. closepos:=value;
  378. end;
  379. function tentryfile.getposition:longint;
  380. begin
  381. if assigned(f) then
  382. result:=f.Position
  383. else
  384. if tempclosed then
  385. result:=closepos
  386. else
  387. result:=0;
  388. end;
  389. function tentryfile.substream(ofs,len:longint):TCStream;
  390. begin
  391. result:=nil;
  392. if assigned(f) then
  393. result:=TCRangeStream.Create(f,ofs,len);
  394. end;
  395. {*****************************************************************************
  396. tentryfile Reading
  397. *****************************************************************************}
  398. function tentryfile.openfile:boolean;
  399. var
  400. strm : TCStream;
  401. begin
  402. openfile:=false;
  403. try
  404. strm:=CFileStreamClass.Create(fname,fmOpenRead)
  405. except
  406. exit;
  407. end;
  408. openfile:=openstream(strm);
  409. fisfile:=result;
  410. end;
  411. function tentryfile.openstream(strm:TCStream):boolean;
  412. var
  413. i : longint;
  414. begin
  415. openstream:=false;
  416. f:=strm;
  417. closed:=false;
  418. {read ppuheader}
  419. fsize:=f.Size;
  420. i:=readheader;
  421. if i<0 then
  422. exit;
  423. {reset buffer}
  424. bufstart:=i;
  425. bufsize:=0;
  426. bufidx:=0;
  427. mode:=1;
  428. FillChar(entry,sizeof(tentry),0);
  429. entryidx:=0;
  430. entrystart:=0;
  431. entrybufstart:=0;
  432. error:=false;
  433. openstream:=true;
  434. end;
  435. procedure tentryfile.reloadbuf;
  436. begin
  437. inc(bufstart,bufsize);
  438. bufsize:=f.Read(buf^,entryfilebufsize);
  439. bufidx:=0;
  440. end;
  441. procedure tentryfile.readdata(out b;len:integer);
  442. var
  443. p,pbuf : pchar;
  444. left : integer;
  445. begin
  446. p:=pchar(@b);
  447. pbuf:=@buf[bufidx];
  448. repeat
  449. left:=bufsize-bufidx;
  450. if len<left then
  451. break;
  452. move(pbuf^,p^,left);
  453. dec(len,left);
  454. inc(p,left);
  455. reloadbuf;
  456. pbuf:=@buf[bufidx];
  457. if bufsize=0 then
  458. exit;
  459. until false;
  460. move(pbuf^,p^,len);
  461. inc(bufidx,len);
  462. end;
  463. procedure tentryfile.skipdata(len:integer);
  464. var
  465. left : integer;
  466. begin
  467. while len>0 do
  468. begin
  469. left:=bufsize-bufidx;
  470. if len>left then
  471. begin
  472. dec(len,left);
  473. reloadbuf;
  474. if bufsize=0 then
  475. exit;
  476. end
  477. else
  478. begin
  479. inc(bufidx,len);
  480. exit;
  481. end;
  482. end;
  483. end;
  484. function tentryfile.readentry:byte;
  485. begin
  486. if entryidx<entry.size then
  487. begin
  488. {$ifdef generic_cpu}
  489. has_more:=true;
  490. {$endif not generic_cpu}
  491. skipdata(entry.size-entryidx);
  492. end;
  493. readdata(entry,sizeof(tentry));
  494. if change_endian then
  495. entry.size:=swapendian(entry.size);
  496. entrystart:=bufstart+bufidx;
  497. entryidx:=0;
  498. {$ifdef generic_cpu}
  499. has_more:=false;
  500. {$endif not generic_cpu}
  501. if not(entry.id in [mainentryid,subentryid]) then
  502. begin
  503. readentry:=iberror;
  504. error:=true;
  505. exit;
  506. end;
  507. readentry:=entry.nr;
  508. end;
  509. function tentryfile.endofentry:boolean;
  510. begin
  511. {$ifdef generic_cpu}
  512. endofentry:=(entryidx=entry.size);
  513. {$else not generic_cpu}
  514. endofentry:=(entryidx>=entry.size);
  515. {$endif not generic_cpu}
  516. end;
  517. function tentryfile.entrysize:longint;
  518. begin
  519. entrysize:=entry.size;
  520. end;
  521. function tentryfile.entryleft:longint;
  522. begin
  523. entryleft:=entry.size-entryidx;
  524. end;
  525. procedure tentryfile.getdatabuf(out b;len:integer;out res:integer);
  526. begin
  527. if entryidx+len>entry.size then
  528. res:=entry.size-entryidx
  529. else
  530. res:=len;
  531. readdata(b,res);
  532. inc(entryidx,res);
  533. end;
  534. procedure tentryfile.getdata(out b;len:integer);
  535. begin
  536. if entryidx+len>entry.size then
  537. begin
  538. error:=true;
  539. exit;
  540. end;
  541. readdata(b,len);
  542. inc(entryidx,len);
  543. end;
  544. function tentryfile.getbyte:byte;
  545. begin
  546. if entryidx+1>entry.size then
  547. begin
  548. error:=true;
  549. result:=0;
  550. exit;
  551. end;
  552. if bufsize-bufidx>=1 then
  553. begin
  554. result:=pbyte(@buf[bufidx])^;
  555. inc(bufidx);
  556. end
  557. else
  558. readdata(result,1);
  559. inc(entryidx);
  560. end;
  561. function tentryfile.getword:word;
  562. begin
  563. if entryidx+2>entry.size then
  564. begin
  565. error:=true;
  566. result:=0;
  567. exit;
  568. end;
  569. if bufsize-bufidx>=sizeof(word) then
  570. begin
  571. result:=Unaligned(pword(@buf[bufidx])^);
  572. inc(bufidx,sizeof(word));
  573. end
  574. else
  575. readdata(result,sizeof(word));
  576. if change_endian then
  577. result:=swapendian(result);
  578. inc(entryidx,2);
  579. end;
  580. function tentryfile.getlongint:longint;
  581. begin
  582. if entryidx+4>entry.size then
  583. begin
  584. error:=true;
  585. result:=0;
  586. exit;
  587. end;
  588. if bufsize-bufidx>=sizeof(longint) then
  589. begin
  590. result:=Unaligned(plongint(@buf[bufidx])^);
  591. inc(bufidx,sizeof(longint));
  592. end
  593. else
  594. readdata(result,sizeof(longint));
  595. if change_endian then
  596. result:=swapendian(result);
  597. inc(entryidx,4);
  598. end;
  599. function tentryfile.getdword:dword;
  600. begin
  601. if entryidx+4>entry.size then
  602. begin
  603. error:=true;
  604. result:=0;
  605. exit;
  606. end;
  607. if bufsize-bufidx>=sizeof(dword) then
  608. begin
  609. result:=Unaligned(pdword(@buf[bufidx])^);
  610. inc(bufidx,sizeof(longint));
  611. end
  612. else
  613. readdata(result,sizeof(dword));
  614. if change_endian then
  615. result:=swapendian(result);
  616. inc(entryidx,4);
  617. end;
  618. function tentryfile.getint64:int64;
  619. begin
  620. if entryidx+8>entry.size then
  621. begin
  622. error:=true;
  623. result:=0;
  624. exit;
  625. end;
  626. if bufsize-bufidx>=sizeof(int64) then
  627. begin
  628. result:=Unaligned(pint64(@buf[bufidx])^);
  629. inc(bufidx,sizeof(int64));
  630. end
  631. else
  632. readdata(result,sizeof(int64));
  633. if change_endian then
  634. result:=swapendian(result);
  635. inc(entryidx,8);
  636. end;
  637. function tentryfile.getqword:qword;
  638. begin
  639. if entryidx+8>entry.size then
  640. begin
  641. error:=true;
  642. result:=0;
  643. exit;
  644. end;
  645. if bufsize-bufidx>=sizeof(qword) then
  646. begin
  647. result:=Unaligned(pqword(@buf[bufidx])^);
  648. inc(bufidx,sizeof(qword));
  649. end
  650. else
  651. readdata(result,sizeof(qword));
  652. if change_endian then
  653. result:=swapendian(result);
  654. inc(entryidx,8);
  655. end;
  656. function tentryfile.getaint:{$ifdef generic_cpu}int64{$else}aint{$endif};
  657. {$ifdef generic_cpu}
  658. var
  659. header : pentryheader;
  660. {$endif generic_cpu}
  661. begin
  662. {$ifdef generic_cpu}
  663. header:=getheaderaddr;
  664. if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
  665. result:=getint64
  666. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
  667. result:=getlongint
  668. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
  669. result:=smallint(getword)
  670. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
  671. result:=shortint(getbyte)
  672. else
  673. begin
  674. error:=true;
  675. result:=0;
  676. end;
  677. {$else not generic_cpu}
  678. case sizeof(aint) of
  679. 8: result:=getint64;
  680. 4: result:=getlongint;
  681. 2: result:=smallint(getword);
  682. 1: result:=shortint(getbyte);
  683. else
  684. begin
  685. RaiseAssertion(2019041801);
  686. result:=0;
  687. end;
  688. end;
  689. {$endif not generic_cpu}
  690. end;
  691. function tentryfile.getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$endif};
  692. {$ifdef generic_cpu}
  693. var
  694. header : pentryheader;
  695. {$endif generic_cpu}
  696. begin
  697. {$ifdef generic_cpu}
  698. header:=getheaderaddr;
  699. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  700. result:=getint64
  701. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
  702. result:=getlongint
  703. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
  704. begin
  705. { result:=smallint(getword);
  706. would have been logical, but it contradicts
  707. definition of asizeint in globtype unit,
  708. which uses 32-bit lngint type even for 16-bit
  709. address size, to be able to cope with
  710. I8086 seg:ofs huge addresses }
  711. result:=getlongint;
  712. end
  713. else
  714. begin
  715. error:=true;
  716. result:=0;
  717. end;
  718. {$else not generic_cpu}
  719. case sizeof(asizeint) of
  720. 8: result:=asizeint(getint64);
  721. 4: result:=asizeint(getlongint);
  722. 2: result:=asizeint(getword);
  723. 1: result:=asizeint(getbyte);
  724. else
  725. begin
  726. RaiseAssertion(2019041802);
  727. result:=0;
  728. end;
  729. end;
  730. {$endif not generic_cpu}
  731. end;
  732. function tentryfile.getpuint:{$ifdef generic_cpu}qword{$else}puint{$endif};
  733. {$ifdef generic_cpu}
  734. var
  735. header : pentryheader;
  736. {$endif generic_cpu}
  737. begin
  738. {$ifdef generic_cpu}
  739. header:=getheaderaddr;
  740. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  741. result:=getqword
  742. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
  743. result:=getdword
  744. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
  745. result:=getword
  746. else
  747. begin
  748. error:=true;
  749. result:=0;
  750. end;
  751. {$else not generic_cpu}
  752. case sizeof(puint) of
  753. 8: result:=getqword;
  754. 4: result:=getdword;
  755. 2: result:=getword;
  756. 1: result:=getbyte;
  757. else
  758. begin
  759. RaiseAssertion(2019041803);
  760. result:=0;
  761. end;
  762. end;
  763. {$endif not generic_cpu}
  764. end;
  765. function tentryfile.getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$endif};
  766. {$ifdef generic_cpu}
  767. var
  768. header : pentryheader;
  769. {$endif generic_cpu}
  770. begin
  771. {$ifdef generic_cpu}
  772. header:=getheaderaddr;
  773. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  774. result:=getqword
  775. else result:=getdword;
  776. {$else not generic_cpu}
  777. {$if sizeof(TConstPtrUInt)=8}
  778. result:=tconstptruint(getint64);
  779. {$else}
  780. result:=TConstPtrUInt(getlongint);
  781. {$endif}
  782. {$endif not generic_cpu}
  783. end;
  784. function tentryfile.getaword:{$ifdef generic_cpu}qword{$else}aword{$endif};
  785. {$ifdef generic_cpu}
  786. var
  787. header : pentryheader;
  788. {$endif generic_cpu}
  789. begin
  790. {$ifdef generic_cpu}
  791. header:=getheaderaddr;
  792. if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
  793. result:=getqword
  794. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
  795. result:=getdword
  796. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
  797. result:=getword
  798. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
  799. result:=getbyte
  800. else
  801. begin
  802. error:=true;
  803. result:=0;
  804. end;
  805. {$else not generic_cpu}
  806. case sizeof(aword) of
  807. 8: result:=getqword;
  808. 4: result:=getdword;
  809. 2: result:=getword;
  810. 1: result:=getbyte;
  811. else
  812. begin
  813. RaiseAssertion(2019041804);
  814. result:=0;
  815. end;
  816. end;
  817. {$endif not generic_cpu}
  818. end;
  819. function tentryfile.getrealsize(sizeofreal : longint):entryreal;
  820. var
  821. e : entryreal;
  822. d : double;
  823. s : single;
  824. begin
  825. if sizeofreal=sizeof(e) then
  826. begin
  827. if entryidx+sizeof(e)>entry.size then
  828. begin
  829. error:=true;
  830. result:=0;
  831. exit;
  832. end;
  833. readdata(e,sizeof(e));
  834. if change_endian then
  835. result:=swapendian_entryreal(e)
  836. else
  837. result:=e;
  838. inc(entryidx,sizeof(e));
  839. exit;
  840. end;
  841. if sizeofreal=sizeof(d) then
  842. begin
  843. if entryidx+sizeof(d)>entry.size then
  844. begin
  845. error:=true;
  846. result:=0;
  847. exit;
  848. end;
  849. readdata(d,sizeof(d));
  850. if change_endian then
  851. result:=swapendian(pqword(@d)^)
  852. else
  853. result:=d;
  854. inc(entryidx,sizeof(d));
  855. result:=d;
  856. exit;
  857. end;
  858. if sizeofreal=sizeof(s) then
  859. begin
  860. if entryidx+sizeof(s)>entry.size then
  861. begin
  862. error:=true;
  863. result:=0;
  864. exit;
  865. end;
  866. readdata(s,sizeof(s));
  867. if change_endian then
  868. result:=swapendian(pdword(@s)^)
  869. else
  870. result:=s;
  871. inc(entryidx,sizeof(s));
  872. result:=s;
  873. exit;
  874. end;
  875. error:=true;
  876. result:=0.0;
  877. end;
  878. function tentryfile.getreal:entryreal;
  879. var
  880. d : entryreal;
  881. hd : double;
  882. begin
  883. if target_info.system=system_x86_64_win64 then
  884. begin
  885. hd:=getrealsize(sizeof(hd));
  886. getreal:=hd;
  887. end
  888. else
  889. begin
  890. d:=getrealsize(sizeof(d));
  891. getreal:=d;
  892. end;
  893. end;
  894. function tentryfile.getboolean:boolean;
  895. begin
  896. result:=boolean(getbyte);
  897. end;
  898. function tentryfile.getstring:string;
  899. begin
  900. result[0]:=chr(getbyte);
  901. if entryidx+length(result)>entry.size then
  902. begin
  903. error:=true;
  904. exit;
  905. end;
  906. ReadData(result[1],length(result));
  907. inc(entryidx,length(result));
  908. end;
  909. function tentryfile.getpshortstring:pshortstring;
  910. var
  911. len: char;
  912. begin
  913. result:=nil;
  914. len:=chr(getbyte);
  915. if entryidx+ord(len)>entry.size then
  916. begin
  917. error:=true;
  918. exit;
  919. end;
  920. getmem(result,ord(len)+1);
  921. result^[0]:=len;
  922. ReadData(result^[1],ord(len));
  923. inc(entryidx,ord(len));
  924. end;
  925. function tentryfile.getansistring:ansistring;
  926. var
  927. len: longint;
  928. begin
  929. len:=getlongint;
  930. if entryidx+len>entry.size then
  931. begin
  932. error:=true;
  933. result:='';
  934. exit;
  935. end;
  936. setlength(result,len);
  937. if len>0 then
  938. getdata(result[1],len);
  939. end;
  940. procedure tentryfile.getsmallset(out b);
  941. var
  942. i : longint;
  943. begin
  944. getdata(b,4);
  945. if change_endian then
  946. for i:=0 to 3 do
  947. Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
  948. end;
  949. procedure tentryfile.getnormalset(out b);
  950. var
  951. i : longint;
  952. begin
  953. getdata(b,32);
  954. if change_endian then
  955. for i:=0 to 31 do
  956. Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
  957. end;
  958. function tentryfile.skipuntilentry(untilb:byte):boolean;
  959. var
  960. b : byte;
  961. begin
  962. repeat
  963. b:=readentry;
  964. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  965. skipuntilentry:=(b=untilb);
  966. end;
  967. {*****************************************************************************
  968. tentryfile Writing
  969. *****************************************************************************}
  970. function tentryfile.createfile:boolean;
  971. var
  972. ok: boolean;
  973. strm : TCStream;
  974. begin
  975. createfile:=false;
  976. strm:=nil;
  977. if outputallowed then
  978. begin
  979. {$ifdef MACOS}
  980. {FPas is FreePascal's creator code on MacOS. See systems/mac_crea.txt}
  981. SetDefaultMacOSCreator('FPas');
  982. SetDefaultMacOSFiletype('FPPU');
  983. {$endif}
  984. ok:=false;
  985. try
  986. strm:=CFileStreamClass.Create(fname,fmCreate);
  987. ok:=true;
  988. except
  989. end;
  990. {$ifdef MACOS}
  991. SetDefaultMacOSCreator('MPS ');
  992. SetDefaultMacOSFiletype('TEXT');
  993. {$endif}
  994. if not ok then
  995. exit;
  996. end;
  997. createfile:=createstream(strm);
  998. fisfile:=result;
  999. end;
  1000. function tentryfile.createstream(strm:TCStream):boolean;
  1001. begin
  1002. createstream:=false;
  1003. if outputallowed then
  1004. begin
  1005. f:=strm;
  1006. mode:=2;
  1007. {write header for sure}
  1008. f.Write(getheaderaddr^,getheadersize);
  1009. end;
  1010. bufsize:=entryfilebufsize;
  1011. bufstart:=getheadersize;
  1012. bufidx:=0;
  1013. {reset}
  1014. resetfile;
  1015. error:=false;
  1016. size:=0;
  1017. entrytyp:=mainentryid;
  1018. {start}
  1019. newentry;
  1020. createstream:=true;
  1021. end;
  1022. procedure tentryfile.writebuf;
  1023. begin
  1024. if outputallowed and
  1025. (bufidx <> 0) then
  1026. f.Write(buf^,bufidx);
  1027. inc(bufstart,bufidx);
  1028. bufidx:=0;
  1029. end;
  1030. procedure tentryfile.writedata(const b;len:integer);
  1031. var
  1032. p : pchar;
  1033. left,
  1034. idx : integer;
  1035. begin
  1036. if not outputallowed then
  1037. exit;
  1038. p:=pchar(@b);
  1039. idx:=0;
  1040. while len>0 do
  1041. begin
  1042. left:=bufsize-bufidx;
  1043. if len>left then
  1044. begin
  1045. move(p[idx],buf[bufidx],left);
  1046. dec(len,left);
  1047. inc(idx,left);
  1048. inc(bufidx,left);
  1049. writebuf;
  1050. end
  1051. else
  1052. begin
  1053. move(p[idx],buf[bufidx],len);
  1054. inc(bufidx,len);
  1055. exit;
  1056. end;
  1057. end;
  1058. end;
  1059. procedure tentryfile.newentry;
  1060. begin
  1061. with entry do
  1062. begin
  1063. id:=entrytyp;
  1064. nr:=ibend;
  1065. size:=0;
  1066. end;
  1067. {Reset Entry State}
  1068. entryidx:=0;
  1069. entrybufstart:=bufstart;
  1070. entrystart:=bufstart+bufidx;
  1071. {Alloc in buffer}
  1072. writedata(entry,sizeof(tentry));
  1073. end;
  1074. procedure tentryfile.writeentry(ibnr:byte);
  1075. var
  1076. opos : integer;
  1077. begin
  1078. {create entry}
  1079. entry.id:=entrytyp;
  1080. entry.nr:=ibnr;
  1081. entry.size:=entryidx;
  1082. {it's already been sent to disk ?}
  1083. if entrybufstart<>bufstart then
  1084. begin
  1085. if outputallowed then
  1086. begin
  1087. {flush to be sure}
  1088. WriteBuf;
  1089. {write entry}
  1090. opos:=f.Position;
  1091. f.Position:=entrystart;
  1092. f.write(entry,sizeof(tentry));
  1093. f.Position:=opos;
  1094. end;
  1095. entrybufstart:=bufstart;
  1096. end
  1097. else
  1098. move(entry,buf[entrystart-bufstart],sizeof(entry));
  1099. {Add New Entry, which is ibend by default}
  1100. entrystart:=bufstart+bufidx; {next entry position}
  1101. newentry;
  1102. end;
  1103. procedure tentryfile.putdata(const b;len:integer);
  1104. begin
  1105. if outputallowed then
  1106. writedata(b,len);
  1107. inc(entryidx,len);
  1108. end;
  1109. procedure tentryfile.putbyte(b:byte);
  1110. begin
  1111. putdata(b,1);
  1112. end;
  1113. procedure tentryfile.putword(w:word);
  1114. begin
  1115. putdata(w,2);
  1116. end;
  1117. procedure tentryfile.putdword(w:dword);
  1118. begin
  1119. putdata(w,4);
  1120. end;
  1121. procedure tentryfile.putlongint(l:longint);
  1122. begin
  1123. putdata(l,4);
  1124. end;
  1125. procedure tentryfile.putint64(i:int64);
  1126. begin
  1127. putdata(i,8);
  1128. end;
  1129. procedure tentryfile.putqword(q:qword);
  1130. begin
  1131. putdata(q,sizeof(qword));
  1132. end;
  1133. procedure tentryfile.putaint(i:aint);
  1134. begin
  1135. putdata(i,sizeof(aint));
  1136. end;
  1137. procedure tentryfile.putasizeint(i: asizeint);
  1138. begin
  1139. putdata(i,sizeof(asizeint));
  1140. end;
  1141. procedure tentryfile.putpuint(i : puint);
  1142. begin
  1143. putdata(i,sizeof(puint));
  1144. end;
  1145. procedure tentryfile.putptruint(v:TConstPtrUInt);
  1146. begin
  1147. {$if sizeof(TConstPtrUInt)=8}
  1148. putint64(int64(v));
  1149. {$else}
  1150. putlongint(longint(v));
  1151. {$endif}
  1152. end;
  1153. procedure tentryfile.putaword(i:aword);
  1154. begin
  1155. putdata(i,sizeof(aword));
  1156. end;
  1157. procedure tentryfile.putreal(d:entryreal);
  1158. var
  1159. hd : double;
  1160. begin
  1161. if target_info.system=system_x86_64_win64 then
  1162. begin
  1163. hd:=d;
  1164. putdata(hd,sizeof(hd));
  1165. end
  1166. else
  1167. putdata(d,sizeof(entryreal));
  1168. end;
  1169. procedure tentryfile.putboolean(b:boolean);
  1170. begin
  1171. putbyte(byte(b));
  1172. end;
  1173. procedure tentryfile.putstring(const s:string);
  1174. begin
  1175. putdata(s,length(s)+1);
  1176. end;
  1177. procedure tentryfile.putansistring(const s:ansistring);
  1178. var
  1179. len: longint;
  1180. begin
  1181. len:=length(s);
  1182. putlongint(len);
  1183. if len>0 then
  1184. putdata(s[1],len);
  1185. end;
  1186. procedure tentryfile.putsmallset(const b);
  1187. var
  1188. l : longint;
  1189. begin
  1190. l:=longint(b);
  1191. putlongint(l);
  1192. end;
  1193. procedure tentryfile.putnormalset(const b);
  1194. begin
  1195. putdata(b,32);
  1196. end;
  1197. procedure tentryfile.tempclose;
  1198. begin
  1199. if not closed then
  1200. begin
  1201. closepos:=f.Position;
  1202. f.Free;
  1203. f:=nil;
  1204. closed:=true;
  1205. tempclosed:=true;
  1206. end;
  1207. end;
  1208. function tentryfile.tempopen:boolean;
  1209. begin
  1210. tempopen:=false;
  1211. if not closed or not tempclosed then
  1212. exit;
  1213. { MG: not sure, if this is correct
  1214. f.position:=0;
  1215. No, f was freed in tempclose above, we need to
  1216. recreate it. PM 2011/06/06 }
  1217. try
  1218. f:=CFileStreamClass.Create(fname,fmOpenRead);
  1219. except
  1220. exit;
  1221. end;
  1222. closed:=false;
  1223. tempclosed:=false;
  1224. { restore state }
  1225. f.Position:=closepos;
  1226. tempopen:=true;
  1227. end;
  1228. end.