entfile.pas 48 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112
  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. // Unused, and wrong as there are entries that are larger then 1024 bytes
  26. {$ifdef CHECK_INPUTPOINTER_LIMITS}
  27. default_entryfilebufsize = 16384;
  28. {$else not CHECK_INPUTPOINTER_LIMITS}
  29. entryfilebufsize = 16384;
  30. {$endif CHECK_INPUTPOINTER_LIMITS}
  31. {ppu entries}
  32. mainentryid = 1;
  33. subentryid = 2;
  34. {special}
  35. iberror = 0;
  36. ibextraheader = 242;
  37. ibpputable = 243;
  38. ibstartrequireds = 244;
  39. ibendrequireds = 245;
  40. ibstartcontained = 246;
  41. ibendcontained = 247;
  42. ibstartdefs = 248;
  43. ibenddefs = 249;
  44. ibstartsyms = 250;
  45. ibendsyms = 251;
  46. ibendinterface = 252;
  47. ibendimplementation = 253;
  48. // ibendbrowser = 254;
  49. ibend = 255;
  50. {general}
  51. ibmodulename = 1;
  52. ibsourcefiles = 2;
  53. ibloadunit = 3;
  54. ibinitunit = 4;
  55. iblinkunitofiles = 5;
  56. iblinkunitstaticlibs = 6;
  57. iblinkunitsharedlibs = 7;
  58. iblinkotherofiles = 8;
  59. iblinkotherstaticlibs = 9;
  60. iblinkothersharedlibs = 10;
  61. ibImportSymbols = 11;
  62. ibsymref = 12;
  63. ibdefref = 13;
  64. ibfeatures = 14;
  65. {$IFDEF MACRO_DIFF_HINT}
  66. ibusedmacros = 16;
  67. {$ENDIF}
  68. ibderefdata = 17;
  69. ibexportedmacros = 18;
  70. ibderefmap = 19;
  71. {syms}
  72. ibtypesym = 20;
  73. ibprocsym = 21;
  74. ibstaticvarsym = 22;
  75. ibconstsym = 23;
  76. ibenumsym = 24;
  77. // ibtypedconstsym = 25;
  78. ibabsolutevarsym = 26;
  79. ibpropertysym = 27;
  80. ibfieldvarsym = 28;
  81. ibunitsym = 29;
  82. iblabelsym = 30;
  83. ibsyssym = 31;
  84. ibnamespacesym = 32;
  85. iblocalvarsym = 33;
  86. ibparavarsym = 34;
  87. ibmacrosym = 35;
  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. ibvariantdef = 57;
  107. ibundefineddef = 58;
  108. ibunicodestringdef = 59;
  109. {implementation/ObjData}
  110. ibnodetree = 80;
  111. ibasmsymbols = 81;
  112. ibresources = 82;
  113. ibcreatedobjtypes = 83;
  114. ibwpofile = 84;
  115. ibmoduleoptions = 85;
  116. ibunitimportsyms = 86;
  117. iborderedsymbols = 87;
  118. ibmainname = 90;
  119. ibsymtableoptions = 91;
  120. ibpackagefiles = 92;
  121. ibpackagename = 93;
  122. ibrecsymtableoptions = 94;
  123. { target-specific things }
  124. iblinkotherframeworks = 100;
  125. ibjvmnamespace = 101;
  126. {$ifdef generic_cpu}
  127. { We need to use the correct size of aint and pint for
  128. the target CPU }
  129. const
  130. CpuAddrBitSize : array[tsystemcpu] of longint =
  131. (
  132. { 0 } 32 {'none'},
  133. { 1 } 32 {'i386'},
  134. { 2 } 32 {'m68k'},
  135. { 3 } 32 {'alpha'},
  136. { 4 } 32 {'powerpc'},
  137. { 5 } 32 {'sparc'},
  138. { 6 } 32 {'vis'},
  139. { 7 } 64 {'ia64'},
  140. { 8 } 64 {'x86_64'},
  141. { 9 } 32 {'mipseb'},
  142. { 10 } 32 {'arm'},
  143. { 11 } 64 {'powerpc64'},
  144. { 12 } 16 {'avr'},
  145. { 13 } 32 {'mipsel'},
  146. { 14 } 32 {'jvm'},
  147. { 15 } 16 {'i8086'},
  148. { 16 } 64 {'aarch64'},
  149. { 17 } 32 {'wasm32'},
  150. { 18 } 64 {'sparc64'},
  151. { 19 } 32 {'riscv32'},
  152. { 20 } 64 {'riscv64'},
  153. { 21 } 32 {'xtensa'},
  154. { 22 } 16 {'z80'},
  155. { 23 } 64 {'mips64'},
  156. { 24 } 64 {'mips64el'},
  157. { 25 } 64 {'loongarch64'}
  158. );
  159. CpuAluBitSize : array[tsystemcpu] of longint =
  160. (
  161. { 0 } 32 {'none'},
  162. { 1 } 32 {'i386'},
  163. { 2 } 32 {'m68k'},
  164. { 3 } 32 {'alpha'},
  165. { 4 } 32 {'powerpc'},
  166. { 5 } 32 {'sparc'},
  167. { 6 } 32 {'vis'},
  168. { 7 } 64 {'ia64'},
  169. { 8 } 64 {'x86_64'},
  170. { 9 } 32 {'mipseb'},
  171. { 10 } 32 {'arm'},
  172. { 11 } 64 {'powerpc64'},
  173. { 12 } 8 {'avr'},
  174. { 13 } 32 {'mipsel'},
  175. { 14 } 64 {'jvm'},
  176. { 15 } 16 {'i8086'},
  177. { 16 } 64 {'aarch64'},
  178. { 17 } 64 {'wasm32'},
  179. { 18 } 64 {'sparc64'},
  180. { 19 } 32 {'riscv32'},
  181. { 20 } 64 {'riscv64'},
  182. { 21 } 32 {'xtensa'},
  183. { 22 } 8 {'z80'},
  184. { 23 } 64 {'mips64'},
  185. { 24 } 64 {'mips64el'},
  186. { 25 } 64 {'loongarch64'}
  187. );
  188. {$endif generic_cpu}
  189. type
  190. { bestreal is defined based on the target architecture }
  191. entryreal=bestreal;
  192. { common part of the header for all kinds of entry files }
  193. tentryheader=record
  194. id : array[1..3] of char;
  195. ver : array[1..3] of char;
  196. compiler : word;
  197. cpu : word;
  198. target : word;
  199. flags : dword;
  200. size : dword; { size of the ppufile without header }
  201. end;
  202. pentryheader=^tentryheader;
  203. tentry=packed record
  204. size : longint;
  205. id : byte;
  206. nr : byte;
  207. end;
  208. tentryfile=class
  209. private
  210. function getposition:longint;
  211. procedure setposition(value:longint);
  212. protected
  213. buf : pchar;
  214. bufstart,
  215. bufsize,
  216. bufidx : integer;
  217. entrybufstart,
  218. entrystart,
  219. entryidx : integer;
  220. entry : tentry;
  221. closed,
  222. tempclosed : boolean;
  223. closepos : integer;
  224. protected
  225. f : TCStream;
  226. {$ifdef DEBUG_PPU}
  227. flog : text;
  228. flog_open : boolean;
  229. ppu_log_level : longint;
  230. ppu_log_idx : integer;
  231. {$endif}
  232. {$ifdef CHECK_INPUTPOINTER_LIMITS}
  233. entryfilebufsize :longint;
  234. {$endif CHECK_INPUTPOINTER_LIMITS}
  235. mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
  236. fisfile : boolean;
  237. fname : string;
  238. fsize : integer;
  239. procedure newheader;virtual;abstract;
  240. function readheader:longint;virtual;abstract;
  241. function outputallowed:boolean;virtual;
  242. procedure resetfile;virtual;abstract;
  243. function getheadersize:longint;virtual;abstract;
  244. function getheaderaddr:pentryheader;virtual;abstract;
  245. procedure RaiseAssertion(Code: Longint); virtual;
  246. public
  247. entrytyp : byte;
  248. size : integer;
  249. change_endian : boolean; { Used in ppudump util }
  250. {$ifdef generic_cpu}
  251. has_more,
  252. {$endif not generic_cpu}
  253. error : boolean;
  254. constructor create(const fn:string
  255. {$ifdef CHECK_INPUTPOINTER_LIMITS}
  256. ;aentryfilebufsize : longint = default_entryfilebufsize
  257. {$endif CHECK_INPUTPOINTER_LIMITS}
  258. );
  259. destructor destroy;override;
  260. function getversion:integer;
  261. procedure flush; {$ifdef USEINLINE}inline;{$endif}
  262. procedure closefile;virtual;
  263. procedure newentry;
  264. property position:longint read getposition write setposition;
  265. { Warning: don't keep the stream open during a tempclose! }
  266. function substream(ofs,len:longint):TCStream;
  267. { Warning: don't use the put* or write* functions anymore when writing through this }
  268. property stream:TCStream read f;
  269. {$ifdef DEBUG_PPU}
  270. procedure ppu_log(st :string);virtual;
  271. procedure ppu_log_val(st :string);virtual;
  272. procedure inc_log_level;
  273. procedure dec_log_level;
  274. {$endif}
  275. {read}
  276. function openfile:boolean;
  277. function openstream(strm:TCStream):boolean;
  278. procedure reloadbuf;
  279. procedure readdata(out b;len:integer);
  280. procedure readdata(const b : TByteDynArray);
  281. procedure readdata(const b : TAnsiCharDynArray);
  282. procedure skipdata(len:integer);
  283. function readentry:byte;
  284. function EndOfEntry:boolean; {$ifdef USEINLINE}inline;{$endif}
  285. function entrysize:longint; {$ifdef USEINLINE}inline;{$endif}
  286. function entryleft:longint; {$ifdef USEINLINE}inline;{$endif}
  287. procedure getdatabuf(out b;len:integer;out res:integer);
  288. procedure getdata(out b;len:integer);
  289. procedure getdata(b : TByteDynArray);
  290. procedure getdata(b : TAnsiCharDynArray);
  291. function getbyte:byte;
  292. function getword:word;
  293. function getdword:dword;
  294. function getlongint:longint;
  295. function getint64:int64;
  296. function getqword:qword;
  297. function getaint:{$ifdef generic_cpu}int64{$else}aint{$ifdef USEINLINE}; inline{$endif}{$endif};
  298. function getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$ifdef USEINLINE}; inline{$endif}{$endif};
  299. function getpuint:{$ifdef generic_cpu}qword{$else}puint{$ifdef USEINLINE}; inline{$endif}{$endif};
  300. function getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$ifdef USEINLINE}; inline{$endif}{$endif};
  301. function getaword:{$ifdef generic_cpu}qword{$else}aword{$ifdef USEINLINE}; inline{$endif}{$endif};
  302. function getreal:entryreal;
  303. function getrealsize(sizeofreal : longint):entryreal;
  304. function getboolean:boolean; {$ifdef USEINLINE}inline;{$endif}
  305. function getstring:string;
  306. function getpshortstring:pshortstring;
  307. function getansistring:ansistring;
  308. procedure getset(out arr: array of byte);
  309. function skipuntilentry(untilb:byte):boolean;
  310. {write}
  311. function createfile:boolean;virtual;
  312. function createstream(strm:TCStream):boolean;
  313. procedure writeheader;virtual;abstract;
  314. procedure writebuf;
  315. procedure writedata(const b;len:integer);
  316. procedure writeentry(ibnr:byte);
  317. procedure putdata(const b;len:integer);virtual;
  318. procedure putbyte(b:byte); {$ifdef USEINLINE}inline;{$endif}
  319. procedure putword(w:word); {$ifdef USEINLINE}inline;{$endif}
  320. procedure putdword(w:dword); {$ifdef USEINLINE}inline;{$endif}
  321. procedure putlongint(l:longint); {$ifdef USEINLINE}inline;{$endif}
  322. procedure putint64(i:int64); {$ifdef USEINLINE}inline;{$endif}
  323. procedure putqword(q:qword); {$ifdef USEINLINE}inline;{$endif}
  324. procedure putaint(i:aint); {$ifdef USEINLINE}inline;{$endif}
  325. procedure putasizeint(i:asizeint); {$ifdef USEINLINE}inline;{$endif}
  326. procedure putpuint(i:puint); {$ifdef USEINLINE}inline;{$endif}
  327. procedure putptruint(v:TConstPtrUInt); {$ifdef USEINLINE}inline;{$endif}
  328. procedure putaword(i:aword); {$ifdef USEINLINE}inline;{$endif}
  329. procedure putreal(d:entryreal);
  330. procedure putboolean(b:boolean); {$ifdef USEINLINE}inline;{$endif}
  331. procedure putstring(const s:string); {$ifdef USEINLINE}inline;{$endif}
  332. procedure putansistring(const s:ansistring);
  333. procedure putset(const arr: array of byte);
  334. procedure tempclose; // MG: not used, obsolete?
  335. function tempopen:boolean; // MG: not used, obsolete?
  336. end;
  337. implementation
  338. uses
  339. {$ifndef FPC_HAS_TYPE_EXTENDED}
  340. {$ifdef FPC_SOFT_FPUX80}
  341. sfpux80,math,
  342. {$endif FPC_SOFT_FPUX80}
  343. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  344. cutils;
  345. function swapendian_entryreal(d:entryreal):entryreal;
  346. type
  347. entryreal_bytes=array[0..sizeof(d)-1] of byte;
  348. var
  349. i:0..sizeof(d)-1;
  350. begin
  351. for i:=low(entryreal_bytes) to high(entryreal_bytes) do
  352. entryreal_bytes(result)[i]:=entryreal_bytes(d)[high(entryreal_bytes)-i];
  353. end;
  354. {*****************************************************************************
  355. tentryfile
  356. *****************************************************************************}
  357. function tentryfile.outputallowed: boolean;
  358. begin
  359. result:=true;
  360. end;
  361. constructor tentryfile.create(const fn:string
  362. {$ifdef CHECK_INPUTPOINTER_LIMITS}
  363. ;aentryfilebufsize : longint = default_entryfilebufsize
  364. {$endif CHECK_INPUTPOINTER_LIMITS}
  365. );
  366. begin
  367. fname:=fn;
  368. fisfile:=false;
  369. change_endian:=false;
  370. mode:=0;
  371. newheader;
  372. error:=false;
  373. closed:=true;
  374. tempclosed:=false;
  375. {$ifdef CHECK_INPUTPOINTER_LIMITS}
  376. entryfilebufsize:=aentryfilebufsize;
  377. {$endif CHECK_INPUTPOINTER_LIMITS}
  378. getmem(buf,entryfilebufsize);
  379. {$ifdef DEBUG_PPU}
  380. assign(flog,fn+'.debug-log');
  381. flog_open:=false;
  382. {$endif DEBUG_PPU}
  383. end;
  384. destructor tentryfile.destroy;
  385. begin
  386. closefile;
  387. {$ifdef DEBUG_PPU}
  388. if flog_open then
  389. close(flog);
  390. flog_open:=false;
  391. {$endif DEBUG_PPU}
  392. if assigned(buf) then
  393. freemem(buf,entryfilebufsize);
  394. end;
  395. {$ifdef DEBUG_PPU}
  396. function entryid_name(nr : byte) : string;
  397. begin
  398. case nr of
  399. {ppu entries}
  400. mainentryid: entryid_name:='main_entry_id';
  401. subentryid: entryid_name:='sub_entry_id';
  402. else
  403. entryid_name:='unknown entryid '+tostr(nr);
  404. end;
  405. end;
  406. function entry_name(nr : byte) : string;
  407. begin
  408. case nr of
  409. {special}
  410. iberror: entry_name:='iberror';
  411. ibextraheader: entry_name:='ibextraheader';
  412. ibpputable: entry_name:='ibpputable';
  413. ibstartrequireds: entry_name:='ibstartrequireds';
  414. ibendrequireds: entry_name:='ibendrequireds';
  415. ibstartcontained: entry_name:='ibstartcontained';
  416. ibendcontained: entry_name:='ibendcontained';
  417. ibstartdefs: entry_name:='ibstartdefs';
  418. ibenddefs: entry_name:='ibenddefs';
  419. ibstartsyms: entry_name:='ibstartsyms';
  420. ibendsyms: entry_name:='ibendsyms';
  421. ibendinterface: entry_name:='ibendinterface';
  422. ibendimplementation: entry_name:='ibendimplementation';
  423. // ibendbrowser: entry_name:='ibendbrowser';
  424. ibend: entry_name:='ibend';
  425. {general}
  426. ibmodulename: entry_name:='ibmodulename';
  427. ibsourcefiles: entry_name:='ibsourcefiles';
  428. ibloadunit: entry_name:='ibloadunit';
  429. ibinitunit: entry_name:='ibinitunit';
  430. iblinkunitofiles: entry_name:='iblinkunitofiles';
  431. iblinkunitstaticlibs: entry_name:='iblinkunitstaticlibs';
  432. iblinkunitsharedlibs: entry_name:='iblinkunitsharedlibs';
  433. iblinkotherofiles: entry_name:='iblinkotherofiles';
  434. iblinkotherstaticlibs: entry_name:='iblinkotherstaticlibs';
  435. iblinkothersharedlibs: entry_name:='iblinkothersharedlibs';
  436. ibImportSymbols: entry_name:='ibImportSymbols';
  437. ibsymref: entry_name:='ibsymref';
  438. ibdefref: entry_name:='ibdefref';
  439. ibfeatures: entry_name:='ibfeatures';
  440. {$IFDEF MACRO_DIFF_HINT}
  441. ibusedmacros: entry_name:='ibusedmacros';
  442. {$ENDIF}
  443. ibderefdata: entry_name:='ibderefdata';
  444. ibexportedmacros: entry_name:='ibexportedmacros';
  445. ibderefmap: entry_name:='ibderefmap';
  446. {syms}
  447. ibtypesym: entry_name:='ibtypesym';
  448. ibprocsym: entry_name:='ibprocsym';
  449. ibstaticvarsym: entry_name:='ibstaticvarsym';
  450. ibconstsym: entry_name:='ibconstsym';
  451. ibenumsym: entry_name:='ibenumsym';
  452. // ibtypedconstsym: entry_name:='ibtypedconstsym';
  453. ibabsolutevarsym: entry_name:='ibabsolutevarsym';
  454. ibpropertysym: entry_name:='ibpropertysym';
  455. ibfieldvarsym: entry_name:='ibfieldvarsym';
  456. ibunitsym: entry_name:='ibunitsym';
  457. iblabelsym: entry_name:='iblabelsym';
  458. ibsyssym: entry_name:='ibsyssym';
  459. ibnamespacesym: entry_name:='ibnamespacesym';
  460. iblocalvarsym: entry_name:='iblocalvarsym';
  461. ibparavarsym: entry_name:='ibparavarsym';
  462. ibmacrosym: entry_name:='ibmacrosym';
  463. {definitions}
  464. iborddef: entry_name:='iborddef';
  465. ibpointerdef: entry_name:='ibpointerdef';
  466. ibarraydef: entry_name:='ibarraydef';
  467. ibprocdef: entry_name:='ibprocdef';
  468. ibshortstringdef: entry_name:='ibshortstringdef';
  469. ibrecorddef: entry_name:='ibrecorddef';
  470. ibfiledef: entry_name:='ibfiledef';
  471. ibformaldef: entry_name:='ibformaldef';
  472. ibobjectdef: entry_name:='ibobjectdef';
  473. ibenumdef: entry_name:='ibenumdef';
  474. ibsetdef: entry_name:='ibsetdef';
  475. ibprocvardef: entry_name:='ibprocvardef';
  476. ibfloatdef: entry_name:='ibfloatdef';
  477. ibclassrefdef: entry_name:='ibclassrefdef';
  478. iblongstringdef: entry_name:='iblongstringdef';
  479. ibansistringdef: entry_name:='ibansistringdef';
  480. ibwidestringdef: entry_name:='ibwidestringdef';
  481. ibvariantdef: entry_name:='ibvariantdef';
  482. ibundefineddef: entry_name:='ibundefineddef';
  483. ibunicodestringdef: entry_name:='ibunicodestringdef';
  484. {implementation/ObjData}
  485. ibnodetree: entry_name:='ibnodetree';
  486. ibasmsymbols: entry_name:='ibasmsymbols';
  487. ibresources: entry_name:='ibresources';
  488. ibcreatedobjtypes: entry_name:='ibcreatedobjtypes';
  489. ibwpofile: entry_name:='ibwpofile';
  490. ibmoduleoptions: entry_name:='ibmoduleoptions';
  491. ibunitimportsyms: entry_name:='ibunitimportsyms';
  492. iborderedsymbols: entry_name:='iborderedsymbols';
  493. ibmainname: entry_name:='ibmainname';
  494. ibsymtableoptions: entry_name:='ibsymtableoptions';
  495. // ibrecsymtableoptions: entry_name:='ibrecsymtableoptions';
  496. ibpackagefiles: entry_name:='ibpackagefiles';
  497. ibpackagename: entry_name:='ibpackagename';
  498. { target-specific things }
  499. iblinkotherframeworks: entry_name:='iblinkotherframeworks';
  500. ibjvmnamespace: entry_name:='ibjvmnamespace';
  501. else
  502. entry_name:='unknown entry '+tostr(nr);
  503. end;
  504. end;
  505. procedure tentryfile.ppu_log(st :string);
  506. begin
  507. if flog_open then
  508. begin
  509. writeln(flog,bufstart+bufidx,': ',st);
  510. end;
  511. {$ifdef IN_PPUDUMP}
  512. writeln(bufstart+bufidx,': ',st);
  513. {$endif}
  514. end;
  515. procedure tentryfile.inc_log_level;
  516. begin
  517. inc(ppu_log_level);
  518. end;
  519. procedure tentryfile.ppu_log_val(st :string);
  520. begin
  521. if flog_open then
  522. begin
  523. writeln(flog,'(',ppu_log_level,') value: ',st);
  524. end;
  525. {$ifdef IN_PPUDUMP}
  526. writeln('(',ppu_log_level,') value: ',st);
  527. {$endif}
  528. end;
  529. procedure tentryfile.dec_log_level;
  530. begin
  531. dec(ppu_log_level);
  532. end;
  533. {$endif}
  534. function tentryfile.getversion:integer;
  535. var
  536. l : integer;
  537. code : integer;
  538. header : pentryheader;
  539. begin
  540. header:=getheaderaddr;
  541. Val(header^.ver[1]+header^.ver[2]+header^.ver[3],l,code);
  542. if code=0 then
  543. result:=l
  544. else
  545. result:=0;
  546. end;
  547. procedure tentryfile.flush;
  548. begin
  549. if mode=2 then
  550. writebuf;
  551. end;
  552. procedure tentryfile.RaiseAssertion(Code: Longint);
  553. begin
  554. { It's down to descendent classes to raise an internal error as desired. [Kit] }
  555. error := true;
  556. end;
  557. procedure tentryfile.closefile;
  558. begin
  559. if mode<>0 then
  560. begin
  561. flush;
  562. {$ifdef DEBUG_PPU}
  563. if (entry.nr<>0) and (mode=1) then
  564. ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
  565. {$endif}
  566. if fisfile then
  567. f.Free;
  568. mode:=0;
  569. closed:=true;
  570. end;
  571. end;
  572. procedure tentryfile.setposition(value:longint);
  573. begin
  574. if assigned(f) then
  575. f.Position:=value
  576. else
  577. if tempclosed then
  578. closepos:=value;
  579. end;
  580. function tentryfile.getposition:longint;
  581. begin
  582. if assigned(f) then
  583. result:=f.Position
  584. else
  585. if tempclosed then
  586. result:=closepos
  587. else
  588. result:=0;
  589. end;
  590. function tentryfile.substream(ofs,len:longint):TCStream;
  591. begin
  592. result:=nil;
  593. if assigned(f) then
  594. result:=TCRangeStream.Create(f,ofs,len);
  595. end;
  596. {*****************************************************************************
  597. tentryfile Reading
  598. *****************************************************************************}
  599. function tentryfile.openfile:boolean;
  600. var
  601. strm : TCStream;
  602. begin
  603. openfile:=false;
  604. try
  605. strm:=CFileStreamClass.Create(fname,fmOpenRead)
  606. except
  607. exit;
  608. end;
  609. openfile:=openstream(strm);
  610. fisfile:=result;
  611. end;
  612. function tentryfile.openstream(strm:TCStream):boolean;
  613. var
  614. i : longint;
  615. begin
  616. openstream:=false;
  617. f:=strm;
  618. closed:=false;
  619. {$ifdef DEBUG_PPU}
  620. {$push}
  621. {$I-}
  622. assign(flog,fname+'.debug-read-log');
  623. rewrite(flog);
  624. if InOutRes=0 then
  625. flog_open:=true;
  626. {$pop}
  627. {$endif DEBUG_PPU}
  628. {read ppuheader}
  629. fsize:=f.Size;
  630. i:=readheader;
  631. if i<0 then
  632. exit;
  633. {reset buffer}
  634. bufstart:=i;
  635. bufsize:=0;
  636. bufidx:=0;
  637. mode:=1;
  638. FillChar(entry,sizeof(tentry),0);
  639. entryidx:=0;
  640. entrystart:=0;
  641. entrybufstart:=0;
  642. error:=false;
  643. openstream:=true;
  644. end;
  645. procedure tentryfile.reloadbuf;
  646. begin
  647. inc(bufstart,bufsize);
  648. bufsize:=f.Read(buf^,entryfilebufsize);
  649. bufidx:=0;
  650. end;
  651. procedure tentryfile.readdata(out b;len:integer);
  652. var
  653. p,pbuf : pchar;
  654. left : integer;
  655. {$ifdef DEBUG_PPU}
  656. i : integer;
  657. {$endif DEBUG_PPU}
  658. begin
  659. p:=pchar(@b);
  660. pbuf:=@buf[bufidx];
  661. repeat
  662. left:=bufsize-bufidx;
  663. if len<left then
  664. break;
  665. move(pbuf^,p^,left);
  666. dec(len,left);
  667. inc(p,left);
  668. reloadbuf;
  669. pbuf:=@buf[bufidx];
  670. if bufsize=0 then
  671. exit;
  672. until false;
  673. move(pbuf^,p^,len);
  674. {$ifdef DEBUG_PPU}
  675. if ppu_log_level <= 0 then
  676. begin
  677. ppu_log('writedata, length='+tostr(len)+' level='+tostr(ppu_log_level));
  678. for i:=0 to len-1 do
  679. ppu_log_val('p['+tostr(i)+']=$'+hexstr(byte(p[i]),2));
  680. end;
  681. {$endif DEBUG_PPU}
  682. inc(bufidx,len);
  683. end;
  684. procedure tentryfile.readdata(const b: TByteDynArray);
  685. begin
  686. ReadData(B[0],Length(B));
  687. end;
  688. procedure tentryfile.readdata(const b: TAnsiCharDynArray);
  689. begin
  690. ReadData(B[0],Length(B));
  691. end;
  692. procedure tentryfile.skipdata(len:integer);
  693. var
  694. left : integer;
  695. begin
  696. {$ifdef DEBUG_PPU}
  697. if len>0 then
  698. ppu_log('explicit skipdata '+tostr(len));
  699. {$endif}
  700. while len>0 do
  701. begin
  702. left:=bufsize-bufidx;
  703. if len>left then
  704. begin
  705. dec(len,left);
  706. reloadbuf;
  707. if bufsize=0 then
  708. exit;
  709. end
  710. else
  711. begin
  712. inc(bufidx,len);
  713. exit;
  714. end;
  715. end;
  716. end;
  717. function tentryfile.readentry:byte;
  718. begin
  719. if entryidx<entry.size then
  720. begin
  721. {$ifdef generic_cpu}
  722. has_more:=true;
  723. {$endif not generic_cpu}
  724. {$ifdef DEBUG_PPU}
  725. if entry.size-entryidx>0 then
  726. ppu_log('skipdata '+tostr(entry.size-entryidx));
  727. {$endif}
  728. skipdata(entry.size-entryidx);
  729. end;
  730. {$ifdef DEBUG_PPU}
  731. if entry.nr<>0 then
  732. ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
  733. ppu_log('entrystart');
  734. {$endif}
  735. readdata(entry,sizeof(tentry));
  736. if change_endian then
  737. entry.size:=swapendian(entry.size);
  738. entrystart:=bufstart+bufidx;
  739. entryidx:=0;
  740. {$ifdef generic_cpu}
  741. has_more:=false;
  742. {$endif not generic_cpu}
  743. if not(entry.id in [mainentryid,subentryid]) then
  744. begin
  745. readentry:=iberror;
  746. error:=true;
  747. exit;
  748. end;
  749. readentry:=entry.nr;
  750. end;
  751. function tentryfile.endofentry: boolean;
  752. begin
  753. {$ifdef generic_cpu}
  754. endofentry:=(entryidx=entry.size);
  755. {$else not generic_cpu}
  756. endofentry:=(entryidx>=entry.size);
  757. {$endif not generic_cpu}
  758. end;
  759. function tentryfile.entrysize:longint;
  760. begin
  761. entrysize:=entry.size;
  762. end;
  763. function tentryfile.entryleft:longint;
  764. begin
  765. entryleft:=entry.size-entryidx;
  766. end;
  767. procedure tentryfile.getdatabuf(out b;len:integer;out res:integer);
  768. begin
  769. if entryidx+len>entry.size then
  770. res:=entry.size-entryidx
  771. else
  772. res:=len;
  773. readdata(b,res);
  774. inc(entryidx,res);
  775. end;
  776. procedure tentryfile.getdata(out b;len:integer);
  777. begin
  778. if entryidx+len>entry.size then
  779. begin
  780. error:=true;
  781. exit;
  782. end;
  783. readdata(b,len);
  784. inc(entryidx,len);
  785. end;
  786. procedure tentryfile.getdata(b: TByteDynArray);
  787. begin
  788. if entryidx+Length(b)>entry.size then
  789. begin
  790. error:=true;
  791. exit;
  792. end;
  793. readdata(b);
  794. inc(entryidx,length(b));
  795. end;
  796. procedure tentryfile.getdata(b: TAnsiCharDynArray);
  797. begin
  798. if entryidx+Length(b)>entry.size then
  799. begin
  800. error:=true;
  801. exit;
  802. end;
  803. readdata(b);
  804. inc(entryidx,length(b));
  805. end;
  806. function tentryfile.getbyte:byte;
  807. begin
  808. if entryidx>=entry.size then
  809. begin
  810. error:=true;
  811. result:=0;
  812. exit;
  813. end;
  814. {$ifdef DEBUG_PPU}
  815. ppu_log('putbyte');
  816. inc_log_level;
  817. {$endif}
  818. if bufidx<bufsize then
  819. begin
  820. result:=pbyte(@buf[bufidx])^;
  821. inc(bufidx);
  822. end
  823. else
  824. readdata(result,1);
  825. {$ifdef DEBUG_PPU}
  826. ppu_log_val(tostr(result));
  827. dec_log_level;
  828. {$endif}
  829. inc(entryidx);
  830. end;
  831. function tentryfile.getword:word;
  832. begin
  833. if entryidx+2>entry.size then
  834. begin
  835. error:=true;
  836. result:=0;
  837. exit;
  838. end;
  839. {$ifdef DEBUG_PPU}
  840. ppu_log('putword');
  841. inc_log_level;
  842. {$endif}
  843. if bufsize-bufidx>=sizeof(word) then
  844. begin
  845. result:=Unaligned(pword(@buf[bufidx])^);
  846. inc(bufidx,sizeof(word));
  847. end
  848. else
  849. readdata(result,sizeof(word));
  850. if change_endian then
  851. result:=swapendian(result);
  852. {$ifdef DEBUG_PPU}
  853. ppu_log_val(tostr(result));
  854. dec_log_level;
  855. {$endif}
  856. inc(entryidx,2);
  857. end;
  858. function tentryfile.getlongint:longint;
  859. begin
  860. if entryidx+4>entry.size then
  861. begin
  862. error:=true;
  863. result:=0;
  864. exit;
  865. end;
  866. {$ifdef DEBUG_PPU}
  867. ppu_log('putlongint');
  868. inc_log_level;
  869. {$endif}
  870. if bufsize-bufidx>=sizeof(longint) then
  871. begin
  872. result:=Unaligned(plongint(@buf[bufidx])^);
  873. inc(bufidx,sizeof(longint));
  874. end
  875. else
  876. readdata(result,sizeof(longint));
  877. if change_endian then
  878. result:=swapendian(result);
  879. {$ifdef DEBUG_PPU}
  880. ppu_log_val(tostr(result));
  881. dec_log_level;
  882. {$endif}
  883. inc(entryidx,4);
  884. end;
  885. function tentryfile.getdword:dword;
  886. begin
  887. if entryidx+4>entry.size then
  888. begin
  889. error:=true;
  890. result:=0;
  891. exit;
  892. end;
  893. {$ifdef DEBUG_PPU}
  894. ppu_log('putdword');
  895. inc_log_level;
  896. {$endif}
  897. if bufsize-bufidx>=sizeof(dword) then
  898. begin
  899. result:=Unaligned(pdword(@buf[bufidx])^);
  900. inc(bufidx,sizeof(longint));
  901. end
  902. else
  903. readdata(result,sizeof(dword));
  904. if change_endian then
  905. result:=swapendian(result);
  906. {$ifdef DEBUG_PPU}
  907. ppu_log_val(tostr(result));
  908. dec_log_level;
  909. {$endif}
  910. inc(entryidx,4);
  911. end;
  912. function tentryfile.getint64:int64;
  913. begin
  914. if entryidx+8>entry.size then
  915. begin
  916. error:=true;
  917. result:=0;
  918. exit;
  919. end;
  920. {$ifdef DEBUG_PPU}
  921. ppu_log('putint64');
  922. inc_log_level;
  923. {$endif}
  924. if bufsize-bufidx>=sizeof(int64) then
  925. begin
  926. result:=Unaligned(pint64(@buf[bufidx])^);
  927. inc(bufidx,sizeof(int64));
  928. end
  929. else
  930. readdata(result,sizeof(int64));
  931. if change_endian then
  932. result:=swapendian(result);
  933. {$ifdef DEBUG_PPU}
  934. ppu_log_val(tostr(result));
  935. dec_log_level;
  936. {$endif}
  937. inc(entryidx,8);
  938. end;
  939. function tentryfile.getqword:qword;
  940. begin
  941. if entryidx+8>entry.size then
  942. begin
  943. error:=true;
  944. result:=0;
  945. exit;
  946. end;
  947. {$ifdef DEBUG_PPU}
  948. ppu_log('putqword');
  949. inc_log_level;
  950. {$endif}
  951. if bufsize-bufidx>=sizeof(qword) then
  952. begin
  953. result:=Unaligned(pqword(@buf[bufidx])^);
  954. inc(bufidx,sizeof(qword));
  955. end
  956. else
  957. readdata(result,sizeof(qword));
  958. if change_endian then
  959. result:=swapendian(result);
  960. {$ifdef DEBUG_PPU}
  961. ppu_log_val(tostr(result));
  962. dec_log_level;
  963. {$endif}
  964. inc(entryidx,8);
  965. end;
  966. function tentryfile.getaint:{$ifdef generic_cpu}int64{$else}aint{$endif};
  967. {$ifdef generic_cpu}
  968. var
  969. header : pentryheader;
  970. {$endif generic_cpu}
  971. begin
  972. {$ifdef DEBUG_PPU}
  973. ppu_log('putaint');
  974. inc_log_level;
  975. {$endif}
  976. {$ifdef generic_cpu}
  977. header:=getheaderaddr;
  978. if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
  979. result:=getint64
  980. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
  981. result:=getlongint
  982. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
  983. result:=smallint(getword)
  984. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
  985. result:=shortint(getbyte)
  986. else
  987. begin
  988. error:=true;
  989. result:=0;
  990. end;
  991. {$else not generic_cpu}
  992. case sizeof(aint) of
  993. 8: result:=getint64;
  994. 4: result:=getlongint;
  995. 2: result:=smallint(getword);
  996. 1: result:=shortint(getbyte);
  997. else
  998. begin
  999. RaiseAssertion(2019041801);
  1000. result:=0;
  1001. end;
  1002. end;
  1003. {$endif not generic_cpu}
  1004. {$ifdef DEBUG_PPU}
  1005. ppu_log_val(tostr(result));
  1006. dec_log_level;
  1007. {$endif}
  1008. end;
  1009. function tentryfile.getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$endif};
  1010. {$ifdef generic_cpu}
  1011. var
  1012. header : pentryheader;
  1013. {$endif generic_cpu}
  1014. begin
  1015. {$ifdef DEBUG_PPU}
  1016. ppu_log('putasizeint');
  1017. inc_log_level;
  1018. {$endif}
  1019. {$ifdef generic_cpu}
  1020. header:=getheaderaddr;
  1021. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  1022. result:=getint64
  1023. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
  1024. result:=getlongint
  1025. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
  1026. begin
  1027. { result:=smallint(getword);
  1028. would have been logical, but it contradicts
  1029. definition of asizeint in globtype unit,
  1030. which uses 32-bit lngint type even for 16-bit
  1031. address size, to be able to cope with
  1032. I8086 seg:ofs huge addresses }
  1033. result:=getlongint;
  1034. end
  1035. else
  1036. begin
  1037. error:=true;
  1038. result:=0;
  1039. end;
  1040. {$else not generic_cpu}
  1041. case sizeof(asizeint) of
  1042. 8: result:=asizeint(getint64);
  1043. 4: result:=asizeint(getlongint);
  1044. 2: result:=asizeint(getword);
  1045. 1: result:=asizeint(getbyte);
  1046. else
  1047. begin
  1048. RaiseAssertion(2019041802);
  1049. result:=0;
  1050. end;
  1051. end;
  1052. {$endif not generic_cpu}
  1053. {$ifdef DEBUG_PPU}
  1054. ppu_log_val(tostr(result));
  1055. dec_log_level;
  1056. {$endif}
  1057. end;
  1058. function tentryfile.getpuint:{$ifdef generic_cpu}qword{$else}puint{$endif};
  1059. {$ifdef generic_cpu}
  1060. var
  1061. header : pentryheader;
  1062. {$endif generic_cpu}
  1063. begin
  1064. {$ifdef DEBUG_PPU}
  1065. ppu_log('putpuint');
  1066. inc_log_level;
  1067. {$endif}
  1068. {$ifdef generic_cpu}
  1069. header:=getheaderaddr;
  1070. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  1071. result:=getqword
  1072. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
  1073. result:=getdword
  1074. else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
  1075. result:=getword
  1076. else
  1077. begin
  1078. error:=true;
  1079. result:=0;
  1080. end;
  1081. {$else not generic_cpu}
  1082. case sizeof(puint) of
  1083. 8: result:=getqword;
  1084. 4: result:=getdword;
  1085. 2: result:=getword;
  1086. 1: result:=getbyte;
  1087. else
  1088. begin
  1089. RaiseAssertion(2019041803);
  1090. result:=0;
  1091. end;
  1092. end;
  1093. {$endif not generic_cpu}
  1094. {$ifdef DEBUG_PPU}
  1095. ppu_log_val(tostr(result));
  1096. dec_log_level;
  1097. {$endif}
  1098. end;
  1099. function tentryfile.getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$endif};
  1100. {$ifdef generic_cpu}
  1101. var
  1102. header : pentryheader;
  1103. {$endif generic_cpu}
  1104. begin
  1105. {$ifdef DEBUG_PPU}
  1106. ppu_log('putptruint');
  1107. inc_log_level;
  1108. {$endif}
  1109. {$ifdef generic_cpu}
  1110. header:=getheaderaddr;
  1111. if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
  1112. result:=getqword
  1113. else result:=getdword;
  1114. {$else not generic_cpu}
  1115. {$if sizeof(TConstPtrUInt)=8}
  1116. result:=tconstptruint(getint64);
  1117. {$else}
  1118. result:=TConstPtrUInt(getlongint);
  1119. {$endif}
  1120. {$endif not generic_cpu}
  1121. {$ifdef DEBUG_PPU}
  1122. ppu_log_val(tostr(result));
  1123. dec_log_level;
  1124. {$endif}
  1125. end;
  1126. function tentryfile.getaword:{$ifdef generic_cpu}qword{$else}aword{$endif};
  1127. {$ifdef generic_cpu}
  1128. var
  1129. header : pentryheader;
  1130. {$endif generic_cpu}
  1131. begin
  1132. {$ifdef DEBUG_PPU}
  1133. ppu_log('putaword');
  1134. inc_log_level;
  1135. {$endif}
  1136. {$ifdef generic_cpu}
  1137. header:=getheaderaddr;
  1138. if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
  1139. result:=getqword
  1140. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
  1141. result:=getdword
  1142. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
  1143. result:=getword
  1144. else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
  1145. result:=getbyte
  1146. else
  1147. begin
  1148. error:=true;
  1149. result:=0;
  1150. end;
  1151. {$else not generic_cpu}
  1152. case sizeof(aword) of
  1153. 8: result:=getqword;
  1154. 4: result:=getdword;
  1155. 2: result:=getword;
  1156. 1: result:=getbyte;
  1157. else
  1158. begin
  1159. RaiseAssertion(2019041804);
  1160. result:=0;
  1161. end;
  1162. end;
  1163. {$endif not generic_cpu}
  1164. {$ifdef DEBUG_PPU}
  1165. ppu_log_val(tostr(result));
  1166. dec_log_level;
  1167. {$endif}
  1168. end;
  1169. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1170. {$ifdef FPC_SOFT_FPUX80}
  1171. { i8086,i386 and x86_64 normally have 80bit float type for
  1172. entryreal, but this is not supported
  1173. on CPUs without 80bit floats.
  1174. Special code is required to handle this. }
  1175. const
  1176. sizeof_floatx80 = 10;
  1177. type
  1178. floatx80_byte_array=array[0..sizeof_floatx80-1] of byte;
  1179. pentryreal=^entryreal;
  1180. function swapendian_floatx80entryreal(d:floatx80_byte_array):floatx80_byte_array;
  1181. var
  1182. i:0..sizeof(d)-1;
  1183. begin
  1184. for i:=low(floatx80_byte_array) to high(floatx80_byte_array) do
  1185. result[i]:=d[high(floatx80_byte_array)-i];
  1186. end;
  1187. {$endif FPC_SOFT_FPUX80}
  1188. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1189. function tentryfile.getrealsize(sizeofreal : longint):entryreal;
  1190. var
  1191. e : entryreal;
  1192. d : double;
  1193. di : qword;{ integer of same size as double }
  1194. s : single;
  1195. si : dword; { integer of same size as single }
  1196. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1197. {$ifdef FPC_SOFT_FPUX80}
  1198. floatx80_ba : floatx80_byte_array;
  1199. floatx80_e: floatx80;
  1200. local_softfloat_exception_mask : TFPUExceptionMask;
  1201. high : word;
  1202. qlow : qword;
  1203. f64 : float64;
  1204. i:byte;
  1205. {$endif}
  1206. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1207. begin
  1208. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1209. {$ifdef FPC_SOFT_FPUX80}
  1210. if sizeofreal=sizeof(floatx80_byte_array) then
  1211. begin
  1212. {$ifdef DEBUG_PPU}
  1213. ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')='));
  1214. inc_log_level;
  1215. {$endif}
  1216. if entryidx+sizeof(floatx80_ba)>entry.size then
  1217. begin
  1218. error:=true;
  1219. result:=0;
  1220. {$ifdef DEBUG_PPU}
  1221. ppu_log_val(realtostr(result));
  1222. dec_log_level;
  1223. {$endif}
  1224. exit;
  1225. end;
  1226. readdata(floatx80_ba,sizeof(floatx80_ba));
  1227. if change_endian then
  1228. floatx80_ba:=swapendian_floatx80entryreal(floatx80_ba);
  1229. {$ifdef FPC_BIG_ENDIAN}
  1230. floatx80_e.high:=pword(@floatx80_ba[0])^;
  1231. floatx80_e.low:=pqword(@floatx80_ba[8])^;
  1232. {$else}
  1233. floatx80_e.high:=pword(@floatx80_ba[8])^;
  1234. floatx80_e.low:=pqword(@floatx80_ba[0])^;
  1235. {$endif}
  1236. local_softfloat_exception_mask:=softfloat_exception_mask;
  1237. softfloat_exception_mask:=[float_flag_invalid,float_flag_denormal,float_flag_divbyzero,float_flag_overflow,float_flag_underflow,float_flag_inexact];
  1238. f64:=floatx80_to_float64(floatx80_e);
  1239. result:=pentryreal(@f64)^;
  1240. softfloat_exception_mask:=local_softfloat_exception_mask;
  1241. inc(entryidx,sizeof(floatx80_ba));
  1242. {$ifdef DEBUG_PPU}
  1243. ppu_log_val(realtostr(result));
  1244. dec_log_level;
  1245. {$endif}
  1246. exit;
  1247. end;
  1248. {$endif FPC_SOFT_FPUX80}
  1249. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1250. if sizeofreal=sizeof(e) then
  1251. begin
  1252. {$ifdef DEBUG_PPU}
  1253. ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
  1254. inc_log_level;
  1255. {$endif}
  1256. if entryidx+sizeof(e)>entry.size then
  1257. begin
  1258. error:=true;
  1259. result:=0;
  1260. {$ifdef DEBUG_PPU}
  1261. ppu_log_val(realtostr(result));
  1262. dec_log_level;
  1263. {$endif}
  1264. exit;
  1265. end;
  1266. readdata(e,sizeof(e));
  1267. if change_endian then
  1268. result:=swapendian_entryreal(e)
  1269. else
  1270. result:=e;
  1271. inc(entryidx,sizeof(e));
  1272. {$ifdef DEBUG_PPU}
  1273. ppu_log_val(realtostr(result));
  1274. dec_log_level;
  1275. {$endif}
  1276. exit;
  1277. end;
  1278. if sizeofreal=sizeof(d) then
  1279. begin
  1280. {$ifdef DEBUG_PPU}
  1281. ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
  1282. inc_log_level;
  1283. {$endif}
  1284. if entryidx+sizeof(d)>entry.size then
  1285. begin
  1286. error:=true;
  1287. result:=0;
  1288. {$ifdef DEBUG_PPU}
  1289. ppu_log_val(realtostr(result));
  1290. dec_log_level;
  1291. {$endif}
  1292. exit;
  1293. end;
  1294. readdata(d,sizeof(d));
  1295. if change_endian then
  1296. begin
  1297. di:=swapendian(pqword(@d)^);
  1298. d:=pdouble(@di)^;
  1299. end;
  1300. result:=d;
  1301. inc(entryidx,sizeof(d));
  1302. result:=d;
  1303. {$ifdef DEBUG_PPU}
  1304. ppu_log_val(realtostr(result));
  1305. dec_log_level;
  1306. {$endif}
  1307. exit;
  1308. end;
  1309. if sizeofreal=sizeof(s) then
  1310. begin
  1311. {$ifdef DEBUG_PPU}
  1312. ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
  1313. inc_log_level;
  1314. {$endif}
  1315. if entryidx+sizeof(s)>entry.size then
  1316. begin
  1317. error:=true;
  1318. result:=0;
  1319. {$ifdef DEBUG_PPU}
  1320. ppu_log_val(realtostr(result));
  1321. dec_log_level;
  1322. {$endif}
  1323. exit;
  1324. end;
  1325. readdata(s,sizeof(s));
  1326. if change_endian then
  1327. begin
  1328. si:=swapendian(pdword(@s)^);
  1329. s:=psingle(@si)^;
  1330. end;
  1331. result:=s;
  1332. inc(entryidx,sizeof(s));
  1333. result:=s;
  1334. {$ifdef DEBUG_PPU}
  1335. ppu_log_val(realtostr(result));
  1336. dec_log_level;
  1337. {$endif}
  1338. exit;
  1339. end;
  1340. error:=true;
  1341. result:=0.0;
  1342. end;
  1343. function tentryfile.getreal:entryreal;
  1344. var
  1345. d : entryreal;
  1346. hd : double;
  1347. begin
  1348. if target_info.system=system_x86_64_win64 then
  1349. begin
  1350. hd:=getrealsize(sizeof(hd));
  1351. getreal:=hd;
  1352. end
  1353. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1354. {$ifdef FPC_SOFT_FPUX80}
  1355. else
  1356. if target_info.cpu in [cpu_i8086, cpu_i386, cpu_x86_64] then
  1357. begin
  1358. d:=getrealsize(sizeof(floatx80_byte_array));
  1359. getreal:=d;
  1360. end
  1361. {$endif def FPC_SOFT_FPUX80}
  1362. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1363. else
  1364. begin
  1365. d:=getrealsize(sizeof(d));
  1366. getreal:=d;
  1367. end;
  1368. end;
  1369. function tentryfile.getboolean:boolean;
  1370. begin
  1371. {$ifdef DEBUG_PPU}
  1372. ppu_log('putboolean');
  1373. {$endif}
  1374. result:=boolean(getbyte);
  1375. end;
  1376. function tentryfile.getstring:string;
  1377. begin
  1378. result[0]:=chr(getbyte);
  1379. {$ifdef DEBUG_PPU}
  1380. ppu_log('putstring,size='+tostr(length(result)+1));
  1381. inc_log_level;
  1382. {$endif}
  1383. if entryidx+length(result)>entry.size then
  1384. begin
  1385. error:=true;
  1386. exit;
  1387. end;
  1388. ReadData(result[1],length(result));
  1389. {$ifdef DEBUG_PPU}
  1390. ppu_log_val(result);
  1391. dec_log_level;
  1392. {$endif}
  1393. inc(entryidx,length(result));
  1394. end;
  1395. function tentryfile.getpshortstring:pshortstring;
  1396. var
  1397. len: char;
  1398. begin
  1399. result:=nil;
  1400. len:=chr(getbyte);
  1401. {$ifdef DEBUG_PPU}
  1402. ppu_log('putstring,size='+tostr(ord(len)+1));
  1403. inc_log_level;
  1404. {$endif}
  1405. if entryidx+ord(len)>entry.size then
  1406. begin
  1407. error:=true;
  1408. exit;
  1409. end;
  1410. getmem(result,ord(len)+1);
  1411. result^[0]:=len;
  1412. ReadData(result^[1],ord(len));
  1413. inc(entryidx,ord(len));
  1414. {$ifdef DEBUG_PPU}
  1415. ppu_log_val(result^);
  1416. dec_log_level;
  1417. {$endif}
  1418. end;
  1419. function tentryfile.getansistring:ansistring;
  1420. var
  1421. len: longint;
  1422. begin
  1423. {$ifdef DEBUG_PPU}
  1424. ppu_log('putansistring');
  1425. inc_log_level;
  1426. {$endif}
  1427. len:=getlongint;
  1428. if entryidx+len>entry.size then
  1429. begin
  1430. error:=true;
  1431. result:='';
  1432. exit;
  1433. end;
  1434. setlength(result,len);
  1435. if len>0 then
  1436. getdata(result[1],len);
  1437. {$ifdef DEBUG_PPU}
  1438. ppu_log_val(result);
  1439. dec_log_level;
  1440. {$endif}
  1441. end;
  1442. procedure tentryfile.getset(out arr: array of byte);
  1443. var
  1444. i : longint;
  1445. begin
  1446. {$ifdef DEBUG_PPU}
  1447. ppu_log('putset');
  1448. inc_log_level;
  1449. {$endif}
  1450. getdata(arr,sizeof(arr));
  1451. if change_endian then
  1452. for i:=low(arr) to high(arr) do
  1453. arr[i]:=reverse_byte(arr[i]);
  1454. {$ifdef DEBUG_PPU}
  1455. for i:=low(arr) to high(arr) do
  1456. ppu_log_val('byte['+tostr(i)+']=$'+hexstr(arr[i],2));
  1457. dec_log_level;
  1458. {$endif}
  1459. end;
  1460. function tentryfile.skipuntilentry(untilb:byte):boolean;
  1461. var
  1462. b : byte;
  1463. begin
  1464. {$ifdef DEBUG_PPU}
  1465. ppu_log('skipuntilentry '+tostr(untilb));
  1466. {$endif}
  1467. repeat
  1468. b:=readentry;
  1469. until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
  1470. skipuntilentry:=(b=untilb);
  1471. end;
  1472. {*****************************************************************************
  1473. tentryfile Writing
  1474. *****************************************************************************}
  1475. function tentryfile.createfile:boolean;
  1476. var
  1477. ok: boolean;
  1478. strm : TCStream;
  1479. begin
  1480. createfile:=false;
  1481. strm:=nil;
  1482. if outputallowed then
  1483. begin
  1484. {$ifdef MACOS}
  1485. {FPas is FreePascal's creator code on MacOS. See systems/mac_crea.txt}
  1486. SetDefaultMacOSCreator('FPas');
  1487. SetDefaultMacOSFiletype('FPPU');
  1488. {$endif}
  1489. ok:=false;
  1490. try
  1491. strm:=CFileStreamClass.Create(fname,fmCreate);
  1492. ok:=true;
  1493. except
  1494. end;
  1495. {$ifdef MACOS}
  1496. SetDefaultMacOSCreator('MPS ');
  1497. SetDefaultMacOSFiletype('TEXT');
  1498. {$endif}
  1499. if not ok then
  1500. exit;
  1501. end;
  1502. createfile:=createstream(strm);
  1503. fisfile:=result;
  1504. end;
  1505. function tentryfile.createstream(strm:TCStream):boolean;
  1506. begin
  1507. createstream:=false;
  1508. if outputallowed then
  1509. begin
  1510. f:=strm;
  1511. mode:=2;
  1512. {write header for sure}
  1513. f.Write(getheaderaddr^,getheadersize);
  1514. end;
  1515. bufsize:=entryfilebufsize;
  1516. bufstart:=getheadersize;
  1517. bufidx:=0;
  1518. {reset}
  1519. resetfile;
  1520. error:=false;
  1521. size:=0;
  1522. entrytyp:=mainentryid;
  1523. {$ifdef DEBUG_PPU}
  1524. {$push}
  1525. {$I-}
  1526. assign(flog,fname+'.debug-write-log');
  1527. rewrite(flog);
  1528. if InOutRes=0 then
  1529. flog_open:=true;
  1530. {$pop}
  1531. {$endif DEBUG_PPU}
  1532. {start}
  1533. newentry;
  1534. createstream:=true;
  1535. end;
  1536. procedure tentryfile.writebuf;
  1537. begin
  1538. if outputallowed and
  1539. (bufidx <> 0) then
  1540. f.Write(buf^,bufidx);
  1541. inc(bufstart,bufidx);
  1542. bufidx:=0;
  1543. end;
  1544. procedure tentryfile.writedata(const b;len:integer);
  1545. var
  1546. p : pchar;
  1547. left,
  1548. idx : integer;
  1549. {$ifdef DEBUG_PPU}
  1550. start_len : integer;
  1551. {$endif}
  1552. begin
  1553. if not outputallowed then
  1554. exit;
  1555. {$ifdef DEBUG_PPU}
  1556. start_len:=len;
  1557. {$endif}
  1558. p:=pchar(@b);
  1559. idx:=0;
  1560. while len>0 do
  1561. begin
  1562. left:=bufsize-bufidx;
  1563. if len>left then
  1564. begin
  1565. move(p[idx],buf[bufidx],left);
  1566. dec(len,left);
  1567. inc(idx,left);
  1568. inc(bufidx,left);
  1569. writebuf;
  1570. end
  1571. else
  1572. begin
  1573. move(p[idx],buf[bufidx],len);
  1574. inc(bufidx,len);
  1575. {$ifdef DEBUG_PPU}
  1576. len:=0;
  1577. {$else}
  1578. exit;
  1579. {$endif}
  1580. end;
  1581. end;
  1582. {$ifdef DEBUG_PPU}
  1583. if (start_len > 0) and (ppu_log_level <= 0) then
  1584. begin
  1585. ppu_log('writedata, length='+tostr(start_len)+' level='+tostr(ppu_log_level));
  1586. for idx:=0 to start_len-1 do
  1587. ppu_log_val('p['+tostr(idx)+']=$'+hexstr(byte(p[idx]),2));
  1588. end;
  1589. {$endif DEBUG_PPU}
  1590. end;
  1591. procedure tentryfile.newentry;
  1592. begin
  1593. with entry do
  1594. begin
  1595. id:=entrytyp;
  1596. nr:=ibend;
  1597. size:=0;
  1598. end;
  1599. {Reset Entry State}
  1600. entryidx:=0;
  1601. entrybufstart:=bufstart;
  1602. entrystart:=bufstart+bufidx;
  1603. {$ifdef DEBUG_PPU}
  1604. ppu_log('entrystart');
  1605. {$endif}
  1606. {Alloc in buffer}
  1607. writedata(entry,sizeof(tentry));
  1608. end;
  1609. procedure tentryfile.writeentry(ibnr:byte);
  1610. var
  1611. opos : integer;
  1612. begin
  1613. {create entry}
  1614. entry.id:=entrytyp;
  1615. entry.nr:=ibnr;
  1616. entry.size:=entryidx;
  1617. {it's already been sent to disk ?}
  1618. if entrybufstart<>bufstart then
  1619. begin
  1620. if outputallowed then
  1621. begin
  1622. {flush to be sure}
  1623. WriteBuf;
  1624. {write entry}
  1625. opos:=f.Position;
  1626. f.Position:=entrystart;
  1627. f.write(entry,sizeof(tentry));
  1628. f.Position:=opos;
  1629. end;
  1630. entrybufstart:=bufstart;
  1631. end
  1632. else
  1633. move(entry,buf[entrystart-bufstart],sizeof(entry));
  1634. {$ifdef DEBUG_PPU}
  1635. ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
  1636. {$endif}
  1637. {Add New Entry, which is ibend by default}
  1638. entrystart:=bufstart+bufidx; {next entry position}
  1639. newentry;
  1640. end;
  1641. procedure tentryfile.putdata(const b;len:integer);
  1642. begin
  1643. if outputallowed then
  1644. writedata(b,len);
  1645. inc(entryidx,len);
  1646. end;
  1647. procedure tentryfile.putbyte(b:byte);
  1648. begin
  1649. {$ifdef DEBUG_PPU}
  1650. ppu_log('putbyte');
  1651. inc_log_level;
  1652. ppu_log_val(tostr(b));
  1653. {$endif}
  1654. putdata(b,1);
  1655. {$ifdef DEBUG_PPU}
  1656. dec_log_level;
  1657. {$endif}
  1658. end;
  1659. procedure tentryfile.putword(w:word);
  1660. begin
  1661. {$ifdef DEBUG_PPU}
  1662. ppu_log('putword');
  1663. inc_log_level;
  1664. ppu_log_val(tostr(w));
  1665. {$endif}
  1666. putdata(w,2);
  1667. {$ifdef DEBUG_PPU}
  1668. dec_log_level;
  1669. {$endif}
  1670. end;
  1671. procedure tentryfile.putdword(w:dword);
  1672. begin
  1673. {$ifdef DEBUG_PPU}
  1674. ppu_log('putdword');
  1675. inc_log_level;
  1676. ppu_log_val(tostr(w));
  1677. {$endif}
  1678. putdata(w,4);
  1679. {$ifdef DEBUG_PPU}
  1680. dec_log_level;
  1681. {$endif}
  1682. end;
  1683. procedure tentryfile.putlongint(l:longint);
  1684. begin
  1685. {$ifdef DEBUG_PPU}
  1686. ppu_log('putlongint');
  1687. inc_log_level;
  1688. ppu_log_val(tostr(l));
  1689. {$endif}
  1690. putdata(l,4);
  1691. {$ifdef DEBUG_PPU}
  1692. dec_log_level;
  1693. {$endif}
  1694. end;
  1695. procedure tentryfile.putint64(i:int64);
  1696. begin
  1697. {$ifdef DEBUG_PPU}
  1698. ppu_log('putint64');
  1699. inc_log_level;
  1700. ppu_log_val(tostr(i));
  1701. {$endif}
  1702. putdata(i,8);
  1703. {$ifdef DEBUG_PPU}
  1704. dec_log_level;
  1705. {$endif}
  1706. end;
  1707. procedure tentryfile.putqword(q:qword);
  1708. begin
  1709. {$ifdef DEBUG_PPU}
  1710. ppu_log('putqword');
  1711. inc_log_level;
  1712. ppu_log_val(tostr(q));
  1713. {$endif}
  1714. putdata(q,sizeof(qword));
  1715. {$ifdef DEBUG_PPU}
  1716. dec_log_level;
  1717. {$endif}
  1718. end;
  1719. procedure tentryfile.putaint(i:aint);
  1720. begin
  1721. {$ifdef DEBUG_PPU}
  1722. ppu_log('putaint');
  1723. inc_log_level;
  1724. case sizeof(aint) of
  1725. 8: ppu_log('putint64');
  1726. 4: ppu_log('putlongint');
  1727. 2: ppu_log('putword');
  1728. 1: ppu_log('putbyte');
  1729. end;
  1730. ppu_log_val(tostr(i));
  1731. {$endif}
  1732. putdata(i,sizeof(aint));
  1733. {$ifdef DEBUG_PPU}
  1734. dec_log_level;
  1735. {$endif}
  1736. end;
  1737. procedure tentryfile.putasizeint(i: asizeint);
  1738. begin
  1739. {$ifdef DEBUG_PPU}
  1740. ppu_log('putasizeint');
  1741. inc_log_level;
  1742. case sizeof(asizeint) of
  1743. 8: ppu_log('putint64');
  1744. 4: ppu_log('putlongint');
  1745. 2: ppu_log('putword');
  1746. 1: ppu_log('putbyte');
  1747. end;
  1748. ppu_log_val(tostr(i));
  1749. {$endif}
  1750. putdata(i,sizeof(asizeint));
  1751. {$ifdef DEBUG_PPU}
  1752. dec_log_level;
  1753. {$endif}
  1754. end;
  1755. procedure tentryfile.putpuint(i : puint);
  1756. begin
  1757. {$ifdef DEBUG_PPU}
  1758. ppu_log('putpuint');
  1759. inc_log_level;
  1760. ppu_log_val(tostr(i));
  1761. {$endif}
  1762. putdata(i,sizeof(puint));
  1763. {$ifdef DEBUG_PPU}
  1764. dec_log_level;
  1765. {$endif}
  1766. end;
  1767. procedure tentryfile.putptruint(v:TConstPtrUInt);
  1768. begin
  1769. {$ifdef DEBUG_PPU}
  1770. ppu_log('putptruint');
  1771. inc_log_level;
  1772. {$endif}
  1773. {$if sizeof(TConstPtrUInt)=8}
  1774. putint64(int64(v));
  1775. {$else}
  1776. putlongint(longint(v));
  1777. {$endif}
  1778. {$ifdef DEBUG_PPU}
  1779. dec_log_level;
  1780. {$endif}
  1781. end;
  1782. procedure tentryfile.putaword(i:aword);
  1783. begin
  1784. {$ifdef DEBUG_PPU}
  1785. ppu_log('putaword');
  1786. inc_log_level;
  1787. ppu_log_val(tostr(i));
  1788. {$endif}
  1789. putdata(i,sizeof(aword));
  1790. {$ifdef DEBUG_PPU}
  1791. dec_log_level;
  1792. {$endif}
  1793. end;
  1794. procedure tentryfile.putreal(d:entryreal);
  1795. var
  1796. hd : double;
  1797. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1798. {$ifdef FPC_SOFT_FPUX80}
  1799. floatx80_ba : floatx80_byte_array;
  1800. floatx80_e : floatx80;
  1801. f64 : float64;
  1802. local_softfloat_exception_mask : TFPUExceptionMask;
  1803. i:byte;
  1804. {$endif FPC_SOFT_FFPUX80}
  1805. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1806. begin
  1807. if target_info.system=system_x86_64_win64 then
  1808. begin
  1809. {$ifdef DEBUG_PPU}
  1810. ppu_log('putreal,size='+tostr(sizeof(hd)));
  1811. inc_log_level;
  1812. ppu_log_val(realtostr(d));
  1813. {$endif}
  1814. hd:=d;
  1815. putdata(hd,sizeof(hd));
  1816. end
  1817. {$ifndef FPC_HAS_TYPE_EXTENDED}
  1818. {$ifdef FPC_SOFT_FPUX80}
  1819. else if target_info.cpu in [cpu_i8086, cpu_i386, cpu_x86_64] then
  1820. begin
  1821. {$ifdef DEBUG_PPU}
  1822. ppu_log('putreal,size='+tostr(sizeof(floatx80_e)));
  1823. inc_log_level;
  1824. {$endif}
  1825. local_softfloat_exception_mask:=softfloat_exception_mask;
  1826. softfloat_exception_mask:=[float_flag_invalid,float_flag_denormal,float_flag_divbyzero,float_flag_overflow,float_flag_underflow,float_flag_inexact];
  1827. f64:=float64(d);
  1828. floatx80_e:=float64_to_floatx80(f64);
  1829. softfloat_exception_mask:=local_softfloat_exception_mask;
  1830. {$ifdef FPC_BIG_ENDIAN}
  1831. pword(@floatx80_ba[0])^:=floatx80_e.high;
  1832. unaligned(pqword(@floatx80_ba[2])^):=floatx80_e.low;
  1833. {$else}
  1834. pword(@floatx80_ba[8])^:=floatx80_e.high;
  1835. pqword(@floatx80_ba[0])^:=floatx80_e.low;
  1836. {$endif}
  1837. putdata(floatx80_ba,sizeof(floatx80_ba));
  1838. end
  1839. {$endif FPC_SOFT_FPUX80}
  1840. {$endif ndef FPC_HAS_TYPE_EXTENDED}
  1841. else
  1842. begin
  1843. {$ifdef DEBUG_PPU}
  1844. ppu_log('putreal,size='+tostr(sizeof(d)));
  1845. inc_log_level;
  1846. ppu_log_val(realtostr(d));
  1847. {$endif}
  1848. putdata(d,sizeof(entryreal));
  1849. end;
  1850. {$ifdef DEBUG_PPU}
  1851. dec_log_level;
  1852. {$endif}
  1853. end;
  1854. procedure tentryfile.putboolean(b:boolean);
  1855. begin
  1856. {$ifdef DEBUG_PPU}
  1857. ppu_log('putboolean');
  1858. inc_log_level;
  1859. {$endif}
  1860. putbyte(byte(b));
  1861. {$ifdef DEBUG_PPU}
  1862. dec_log_level;
  1863. {$endif}
  1864. end;
  1865. procedure tentryfile.putstring(const s:string);
  1866. begin
  1867. {$ifdef DEBUG_PPU}
  1868. { The reading method uses getbyte, so fake it here }
  1869. ppu_log('putbyte');
  1870. inc_log_level;
  1871. inc(bufidx);
  1872. ppu_log('putstring,size='+tostr(length(s)+1));
  1873. dec(bufidx);
  1874. ppu_log_val(s);
  1875. {$endif}
  1876. putdata(s,length(s)+1);
  1877. {$ifdef DEBUG_PPU}
  1878. dec_log_level;
  1879. {$endif}
  1880. end;
  1881. procedure tentryfile.putansistring(const s:ansistring);
  1882. var
  1883. len: longint;
  1884. begin
  1885. len:=length(s);
  1886. {$ifdef DEBUG_PPU}
  1887. ppu_log('putansistring');
  1888. inc_log_level;
  1889. ppu_log_val(s);
  1890. {$endif}
  1891. putlongint(len);
  1892. if len>0 then
  1893. putdata(s[1],len);
  1894. {$ifdef DEBUG_PPU}
  1895. dec_log_level;
  1896. {$endif}
  1897. end;
  1898. procedure tentryfile.putset(const arr: array of byte);
  1899. {$ifdef DEBUG_PPU}
  1900. var
  1901. i : byte;
  1902. {$endif}
  1903. begin
  1904. {$ifdef DEBUG_PPU}
  1905. ppu_log('putset');
  1906. inc_log_level;
  1907. {$endif}
  1908. putdata(arr,sizeof(arr));
  1909. {$ifdef DEBUG_PPU}
  1910. for i:=0 to sizeof(arr)-1 do
  1911. ppu_log_val('byte['+tostr(i)+']=$'+hexstr(arr[i],2));
  1912. dec_log_level;
  1913. {$endif}
  1914. end;
  1915. procedure tentryfile.tempclose;
  1916. begin
  1917. if not closed then
  1918. begin
  1919. closepos:=f.Position;
  1920. f.Free;
  1921. f:=nil;
  1922. closed:=true;
  1923. tempclosed:=true;
  1924. end;
  1925. end;
  1926. function tentryfile.tempopen:boolean;
  1927. begin
  1928. tempopen:=false;
  1929. if not closed or not tempclosed then
  1930. exit;
  1931. { MG: not sure, if this is correct
  1932. f.position:=0;
  1933. No, f was freed in tempclose above, we need to
  1934. recreate it. PM 2011/06/06 }
  1935. try
  1936. f:=CFileStreamClass.Create(fname,fmOpenRead);
  1937. except
  1938. exit;
  1939. end;
  1940. closed:=false;
  1941. tempclosed:=false;
  1942. { restore state }
  1943. f.Position:=closepos;
  1944. tempopen:=true;
  1945. end;
  1946. end.