mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 19:48:01 +02:00
2113 lines
48 KiB
ObjectPascal
2113 lines
48 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2013 by Free Pascal development team
|
|
|
|
Routines to read/write entry based files (ppu, pcp)
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit entfile;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
systems,globtype,constexp,cstreams;
|
|
|
|
const
|
|
{ buffer sizes }
|
|
maxentrysize = 1024;
|
|
// Unused, and wrong as there are entries that are larger then 1024 bytes
|
|
|
|
{$ifdef CHECK_INPUTPOINTER_LIMITS}
|
|
default_entryfilebufsize = 16384;
|
|
{$else not CHECK_INPUTPOINTER_LIMITS}
|
|
entryfilebufsize = 16384;
|
|
{$endif CHECK_INPUTPOINTER_LIMITS}
|
|
|
|
{ppu entries}
|
|
mainentryid = 1;
|
|
subentryid = 2;
|
|
{special}
|
|
iberror = 0;
|
|
ibextraheader = 242;
|
|
ibpputable = 243;
|
|
ibstartrequireds = 244;
|
|
ibendrequireds = 245;
|
|
ibstartcontained = 246;
|
|
ibendcontained = 247;
|
|
ibstartdefs = 248;
|
|
ibenddefs = 249;
|
|
ibstartsyms = 250;
|
|
ibendsyms = 251;
|
|
ibendinterface = 252;
|
|
ibendimplementation = 253;
|
|
// ibendbrowser = 254;
|
|
ibend = 255;
|
|
{general}
|
|
ibmodulename = 1;
|
|
ibsourcefiles = 2;
|
|
ibloadunit = 3;
|
|
ibinitunit = 4;
|
|
iblinkunitofiles = 5;
|
|
iblinkunitstaticlibs = 6;
|
|
iblinkunitsharedlibs = 7;
|
|
iblinkotherofiles = 8;
|
|
iblinkotherstaticlibs = 9;
|
|
iblinkothersharedlibs = 10;
|
|
ibImportSymbols = 11;
|
|
ibsymref = 12;
|
|
ibdefref = 13;
|
|
ibfeatures = 14;
|
|
{$IFDEF MACRO_DIFF_HINT}
|
|
ibusedmacros = 16;
|
|
{$ENDIF}
|
|
ibderefdata = 17;
|
|
ibexportedmacros = 18;
|
|
ibderefmap = 19;
|
|
|
|
{syms}
|
|
ibtypesym = 20;
|
|
ibprocsym = 21;
|
|
ibstaticvarsym = 22;
|
|
ibconstsym = 23;
|
|
ibenumsym = 24;
|
|
// ibtypedconstsym = 25;
|
|
ibabsolutevarsym = 26;
|
|
ibpropertysym = 27;
|
|
ibfieldvarsym = 28;
|
|
ibunitsym = 29;
|
|
iblabelsym = 30;
|
|
ibsyssym = 31;
|
|
ibnamespacesym = 32;
|
|
iblocalvarsym = 33;
|
|
ibparavarsym = 34;
|
|
ibmacrosym = 35;
|
|
{definitions}
|
|
iborddef = 40;
|
|
ibpointerdef = 41;
|
|
ibarraydef = 42;
|
|
ibprocdef = 43;
|
|
ibshortstringdef = 44;
|
|
ibrecorddef = 45;
|
|
ibfiledef = 46;
|
|
ibformaldef = 47;
|
|
ibobjectdef = 48;
|
|
ibenumdef = 49;
|
|
ibsetdef = 50;
|
|
ibprocvardef = 51;
|
|
ibfloatdef = 52;
|
|
ibclassrefdef = 53;
|
|
iblongstringdef = 54;
|
|
ibansistringdef = 55;
|
|
ibwidestringdef = 56;
|
|
ibvariantdef = 57;
|
|
ibundefineddef = 58;
|
|
ibunicodestringdef = 59;
|
|
{implementation/ObjData}
|
|
ibnodetree = 80;
|
|
ibasmsymbols = 81;
|
|
ibresources = 82;
|
|
ibcreatedobjtypes = 83;
|
|
ibwpofile = 84;
|
|
ibmoduleoptions = 85;
|
|
ibunitimportsyms = 86;
|
|
iborderedsymbols = 87;
|
|
|
|
ibmainname = 90;
|
|
ibsymtableoptions = 91;
|
|
ibpackagefiles = 92;
|
|
ibpackagename = 93;
|
|
ibrecsymtableoptions = 94;
|
|
{ target-specific things }
|
|
iblinkotherframeworks = 100;
|
|
ibjvmnamespace = 101;
|
|
|
|
{$ifdef generic_cpu}
|
|
{ We need to use the correct size of aint and pint for
|
|
the target CPU }
|
|
const
|
|
CpuAddrBitSize : array[tsystemcpu] of longint =
|
|
(
|
|
{ 0 } 32 {'none'},
|
|
{ 1 } 32 {'i386'},
|
|
{ 2 } 32 {'m68k'},
|
|
{ 3 } 32 {'alpha'},
|
|
{ 4 } 32 {'powerpc'},
|
|
{ 5 } 32 {'sparc'},
|
|
{ 6 } 32 {'vis'},
|
|
{ 7 } 64 {'ia64'},
|
|
{ 8 } 64 {'x86_64'},
|
|
{ 9 } 32 {'mipseb'},
|
|
{ 10 } 32 {'arm'},
|
|
{ 11 } 64 {'powerpc64'},
|
|
{ 12 } 16 {'avr'},
|
|
{ 13 } 32 {'mipsel'},
|
|
{ 14 } 32 {'jvm'},
|
|
{ 15 } 16 {'i8086'},
|
|
{ 16 } 64 {'aarch64'},
|
|
{ 17 } 32 {'wasm32'},
|
|
{ 18 } 64 {'sparc64'},
|
|
{ 19 } 32 {'riscv32'},
|
|
{ 20 } 64 {'riscv64'},
|
|
{ 21 } 32 {'xtensa'},
|
|
{ 22 } 16 {'z80'},
|
|
{ 23 } 64 {'mips64'},
|
|
{ 24 } 64 {'mips64el'},
|
|
{ 25 } 64 {'loongarch64'}
|
|
);
|
|
CpuAluBitSize : array[tsystemcpu] of longint =
|
|
(
|
|
{ 0 } 32 {'none'},
|
|
{ 1 } 32 {'i386'},
|
|
{ 2 } 32 {'m68k'},
|
|
{ 3 } 32 {'alpha'},
|
|
{ 4 } 32 {'powerpc'},
|
|
{ 5 } 32 {'sparc'},
|
|
{ 6 } 32 {'vis'},
|
|
{ 7 } 64 {'ia64'},
|
|
{ 8 } 64 {'x86_64'},
|
|
{ 9 } 32 {'mipseb'},
|
|
{ 10 } 32 {'arm'},
|
|
{ 11 } 64 {'powerpc64'},
|
|
{ 12 } 8 {'avr'},
|
|
{ 13 } 32 {'mipsel'},
|
|
{ 14 } 64 {'jvm'},
|
|
{ 15 } 16 {'i8086'},
|
|
{ 16 } 64 {'aarch64'},
|
|
{ 17 } 64 {'wasm32'},
|
|
{ 18 } 64 {'sparc64'},
|
|
{ 19 } 32 {'riscv32'},
|
|
{ 20 } 64 {'riscv64'},
|
|
{ 21 } 32 {'xtensa'},
|
|
{ 22 } 8 {'z80'},
|
|
{ 23 } 64 {'mips64'},
|
|
{ 24 } 64 {'mips64el'},
|
|
{ 25 } 64 {'loongarch64'}
|
|
);
|
|
{$endif generic_cpu}
|
|
|
|
type
|
|
{ bestreal is defined based on the target architecture }
|
|
entryreal=bestreal;
|
|
|
|
{ common part of the header for all kinds of entry files }
|
|
tentryheader=record
|
|
id : array[1..3] of char;
|
|
ver : array[1..3] of char;
|
|
compiler : word;
|
|
cpu : word;
|
|
target : word;
|
|
flags : dword;
|
|
size : dword; { size of the ppufile without header }
|
|
end;
|
|
pentryheader=^tentryheader;
|
|
|
|
tentry=packed record
|
|
size : longint;
|
|
id : byte;
|
|
nr : byte;
|
|
end;
|
|
|
|
tentryfile=class
|
|
private
|
|
function getposition:longint;
|
|
procedure setposition(value:longint);
|
|
protected
|
|
buf : pchar;
|
|
bufstart,
|
|
bufsize,
|
|
bufidx : integer;
|
|
entrybufstart,
|
|
entrystart,
|
|
entryidx : integer;
|
|
entry : tentry;
|
|
closed,
|
|
tempclosed : boolean;
|
|
closepos : integer;
|
|
protected
|
|
f : TCStream;
|
|
{$ifdef DEBUG_PPU}
|
|
flog : text;
|
|
flog_open : boolean;
|
|
ppu_log_level : longint;
|
|
ppu_log_idx : integer;
|
|
{$endif}
|
|
{$ifdef CHECK_INPUTPOINTER_LIMITS}
|
|
entryfilebufsize :longint;
|
|
{$endif CHECK_INPUTPOINTER_LIMITS}
|
|
mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
|
|
fisfile : boolean;
|
|
fname : string;
|
|
fsize : integer;
|
|
procedure newheader;virtual;abstract;
|
|
function readheader:longint;virtual;abstract;
|
|
function outputallowed:boolean;virtual;
|
|
procedure resetfile;virtual;abstract;
|
|
function getheadersize:longint;virtual;abstract;
|
|
function getheaderaddr:pentryheader;virtual;abstract;
|
|
procedure RaiseAssertion(Code: Longint); virtual;
|
|
public
|
|
entrytyp : byte;
|
|
size : integer;
|
|
change_endian : boolean; { Used in ppudump util }
|
|
{$ifdef generic_cpu}
|
|
has_more,
|
|
{$endif not generic_cpu}
|
|
error : boolean;
|
|
constructor create(const fn:string
|
|
{$ifdef CHECK_INPUTPOINTER_LIMITS}
|
|
;aentryfilebufsize : longint = default_entryfilebufsize
|
|
{$endif CHECK_INPUTPOINTER_LIMITS}
|
|
);
|
|
destructor destroy;override;
|
|
function getversion:integer;
|
|
procedure flush; {$ifdef USEINLINE}inline;{$endif}
|
|
procedure closefile;virtual;
|
|
procedure newentry;
|
|
property position:longint read getposition write setposition;
|
|
{ Warning: don't keep the stream open during a tempclose! }
|
|
function substream(ofs,len:longint):TCStream;
|
|
{ Warning: don't use the put* or write* functions anymore when writing through this }
|
|
property stream:TCStream read f;
|
|
{$ifdef DEBUG_PPU}
|
|
procedure ppu_log(st :string);virtual;
|
|
procedure ppu_log_val(st :string);virtual;
|
|
procedure inc_log_level;
|
|
procedure dec_log_level;
|
|
{$endif}
|
|
{read}
|
|
function openfile:boolean;
|
|
function openstream(strm:TCStream):boolean;
|
|
procedure reloadbuf;
|
|
procedure readdata(out b;len:integer);
|
|
procedure readdata(const b : TByteDynArray);
|
|
procedure readdata(const b : TAnsiCharDynArray);
|
|
procedure skipdata(len:integer);
|
|
function readentry:byte;
|
|
function EndOfEntry:boolean; {$ifdef USEINLINE}inline;{$endif}
|
|
function entrysize:longint; {$ifdef USEINLINE}inline;{$endif}
|
|
function entryleft:longint; {$ifdef USEINLINE}inline;{$endif}
|
|
procedure getdatabuf(out b;len:integer;out res:integer);
|
|
procedure getdata(out b;len:integer);
|
|
procedure getdata(b : TByteDynArray);
|
|
procedure getdata(b : TAnsiCharDynArray);
|
|
function getbyte:byte;
|
|
function getword:word;
|
|
function getdword:dword;
|
|
function getlongint:longint;
|
|
function getint64:int64;
|
|
function getqword:qword;
|
|
function getaint:{$ifdef generic_cpu}int64{$else}aint{$ifdef USEINLINE}; inline{$endif}{$endif};
|
|
function getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$ifdef USEINLINE}; inline{$endif}{$endif};
|
|
function getpuint:{$ifdef generic_cpu}qword{$else}puint{$ifdef USEINLINE}; inline{$endif}{$endif};
|
|
function getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$ifdef USEINLINE}; inline{$endif}{$endif};
|
|
function getaword:{$ifdef generic_cpu}qword{$else}aword{$ifdef USEINLINE}; inline{$endif}{$endif};
|
|
function getreal:entryreal;
|
|
function getrealsize(sizeofreal : longint):entryreal;
|
|
function getboolean:boolean; {$ifdef USEINLINE}inline;{$endif}
|
|
function getstring:string;
|
|
function getpshortstring:pshortstring;
|
|
function getansistring:ansistring;
|
|
procedure getset(out arr: array of byte);
|
|
function skipuntilentry(untilb:byte):boolean;
|
|
{write}
|
|
function createfile:boolean;virtual;
|
|
function createstream(strm:TCStream):boolean;
|
|
procedure writeheader;virtual;abstract;
|
|
procedure writebuf;
|
|
procedure writedata(const b;len:integer);
|
|
procedure writeentry(ibnr:byte);
|
|
procedure putdata(const b;len:integer);virtual;
|
|
procedure putbyte(b:byte); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putword(w:word); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putdword(w:dword); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putlongint(l:longint); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putint64(i:int64); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putqword(q:qword); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putaint(i:aint); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putasizeint(i:asizeint); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putpuint(i:puint); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putptruint(v:TConstPtrUInt); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putaword(i:aword); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putreal(d:entryreal);
|
|
procedure putboolean(b:boolean); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putstring(const s:string); {$ifdef USEINLINE}inline;{$endif}
|
|
procedure putansistring(const s:ansistring);
|
|
|
|
procedure putset(const arr: array of byte);
|
|
procedure tempclose; // MG: not used, obsolete?
|
|
function tempopen:boolean; // MG: not used, obsolete?
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
sfpux80,math,
|
|
{$endif FPC_SOFT_FPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
cutils;
|
|
|
|
|
|
function swapendian_entryreal(d:entryreal):entryreal;
|
|
type
|
|
entryreal_bytes=array[0..sizeof(d)-1] of byte;
|
|
var
|
|
i:0..sizeof(d)-1;
|
|
begin
|
|
for i:=low(entryreal_bytes) to high(entryreal_bytes) do
|
|
entryreal_bytes(result)[i]:=entryreal_bytes(d)[high(entryreal_bytes)-i];
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
tentryfile
|
|
*****************************************************************************}
|
|
|
|
function tentryfile.outputallowed: boolean;
|
|
begin
|
|
result:=true;
|
|
end;
|
|
|
|
|
|
constructor tentryfile.create(const fn:string
|
|
{$ifdef CHECK_INPUTPOINTER_LIMITS}
|
|
;aentryfilebufsize : longint = default_entryfilebufsize
|
|
{$endif CHECK_INPUTPOINTER_LIMITS}
|
|
);
|
|
begin
|
|
fname:=fn;
|
|
fisfile:=false;
|
|
change_endian:=false;
|
|
mode:=0;
|
|
newheader;
|
|
error:=false;
|
|
closed:=true;
|
|
tempclosed:=false;
|
|
{$ifdef CHECK_INPUTPOINTER_LIMITS}
|
|
entryfilebufsize:=aentryfilebufsize;
|
|
{$endif CHECK_INPUTPOINTER_LIMITS}
|
|
getmem(buf,entryfilebufsize);
|
|
{$ifdef DEBUG_PPU}
|
|
assign(flog,fn+'.debug-log');
|
|
flog_open:=false;
|
|
{$endif DEBUG_PPU}
|
|
end;
|
|
|
|
|
|
destructor tentryfile.destroy;
|
|
begin
|
|
closefile;
|
|
{$ifdef DEBUG_PPU}
|
|
if flog_open then
|
|
close(flog);
|
|
flog_open:=false;
|
|
{$endif DEBUG_PPU}
|
|
if assigned(buf) then
|
|
freemem(buf,entryfilebufsize);
|
|
end;
|
|
|
|
{$ifdef DEBUG_PPU}
|
|
|
|
function entryid_name(nr : byte) : string;
|
|
begin
|
|
case nr of
|
|
{ppu entries}
|
|
mainentryid: entryid_name:='main_entry_id';
|
|
subentryid: entryid_name:='sub_entry_id';
|
|
else
|
|
entryid_name:='unknown entryid '+tostr(nr);
|
|
end;
|
|
end;
|
|
|
|
function entry_name(nr : byte) : string;
|
|
begin
|
|
case nr of
|
|
{special}
|
|
iberror: entry_name:='iberror';
|
|
ibextraheader: entry_name:='ibextraheader';
|
|
ibpputable: entry_name:='ibpputable';
|
|
ibstartrequireds: entry_name:='ibstartrequireds';
|
|
ibendrequireds: entry_name:='ibendrequireds';
|
|
ibstartcontained: entry_name:='ibstartcontained';
|
|
ibendcontained: entry_name:='ibendcontained';
|
|
ibstartdefs: entry_name:='ibstartdefs';
|
|
ibenddefs: entry_name:='ibenddefs';
|
|
ibstartsyms: entry_name:='ibstartsyms';
|
|
ibendsyms: entry_name:='ibendsyms';
|
|
ibendinterface: entry_name:='ibendinterface';
|
|
ibendimplementation: entry_name:='ibendimplementation';
|
|
// ibendbrowser: entry_name:='ibendbrowser';
|
|
ibend: entry_name:='ibend';
|
|
{general}
|
|
ibmodulename: entry_name:='ibmodulename';
|
|
ibsourcefiles: entry_name:='ibsourcefiles';
|
|
ibloadunit: entry_name:='ibloadunit';
|
|
ibinitunit: entry_name:='ibinitunit';
|
|
iblinkunitofiles: entry_name:='iblinkunitofiles';
|
|
iblinkunitstaticlibs: entry_name:='iblinkunitstaticlibs';
|
|
iblinkunitsharedlibs: entry_name:='iblinkunitsharedlibs';
|
|
iblinkotherofiles: entry_name:='iblinkotherofiles';
|
|
iblinkotherstaticlibs: entry_name:='iblinkotherstaticlibs';
|
|
iblinkothersharedlibs: entry_name:='iblinkothersharedlibs';
|
|
ibImportSymbols: entry_name:='ibImportSymbols';
|
|
ibsymref: entry_name:='ibsymref';
|
|
ibdefref: entry_name:='ibdefref';
|
|
ibfeatures: entry_name:='ibfeatures';
|
|
{$IFDEF MACRO_DIFF_HINT}
|
|
ibusedmacros: entry_name:='ibusedmacros';
|
|
{$ENDIF}
|
|
ibderefdata: entry_name:='ibderefdata';
|
|
ibexportedmacros: entry_name:='ibexportedmacros';
|
|
ibderefmap: entry_name:='ibderefmap';
|
|
|
|
{syms}
|
|
ibtypesym: entry_name:='ibtypesym';
|
|
ibprocsym: entry_name:='ibprocsym';
|
|
ibstaticvarsym: entry_name:='ibstaticvarsym';
|
|
ibconstsym: entry_name:='ibconstsym';
|
|
ibenumsym: entry_name:='ibenumsym';
|
|
// ibtypedconstsym: entry_name:='ibtypedconstsym';
|
|
ibabsolutevarsym: entry_name:='ibabsolutevarsym';
|
|
ibpropertysym: entry_name:='ibpropertysym';
|
|
ibfieldvarsym: entry_name:='ibfieldvarsym';
|
|
ibunitsym: entry_name:='ibunitsym';
|
|
iblabelsym: entry_name:='iblabelsym';
|
|
ibsyssym: entry_name:='ibsyssym';
|
|
ibnamespacesym: entry_name:='ibnamespacesym';
|
|
iblocalvarsym: entry_name:='iblocalvarsym';
|
|
ibparavarsym: entry_name:='ibparavarsym';
|
|
ibmacrosym: entry_name:='ibmacrosym';
|
|
{definitions}
|
|
iborddef: entry_name:='iborddef';
|
|
ibpointerdef: entry_name:='ibpointerdef';
|
|
ibarraydef: entry_name:='ibarraydef';
|
|
ibprocdef: entry_name:='ibprocdef';
|
|
ibshortstringdef: entry_name:='ibshortstringdef';
|
|
ibrecorddef: entry_name:='ibrecorddef';
|
|
ibfiledef: entry_name:='ibfiledef';
|
|
ibformaldef: entry_name:='ibformaldef';
|
|
ibobjectdef: entry_name:='ibobjectdef';
|
|
ibenumdef: entry_name:='ibenumdef';
|
|
ibsetdef: entry_name:='ibsetdef';
|
|
ibprocvardef: entry_name:='ibprocvardef';
|
|
ibfloatdef: entry_name:='ibfloatdef';
|
|
ibclassrefdef: entry_name:='ibclassrefdef';
|
|
iblongstringdef: entry_name:='iblongstringdef';
|
|
ibansistringdef: entry_name:='ibansistringdef';
|
|
ibwidestringdef: entry_name:='ibwidestringdef';
|
|
ibvariantdef: entry_name:='ibvariantdef';
|
|
ibundefineddef: entry_name:='ibundefineddef';
|
|
ibunicodestringdef: entry_name:='ibunicodestringdef';
|
|
{implementation/ObjData}
|
|
ibnodetree: entry_name:='ibnodetree';
|
|
ibasmsymbols: entry_name:='ibasmsymbols';
|
|
ibresources: entry_name:='ibresources';
|
|
ibcreatedobjtypes: entry_name:='ibcreatedobjtypes';
|
|
ibwpofile: entry_name:='ibwpofile';
|
|
ibmoduleoptions: entry_name:='ibmoduleoptions';
|
|
ibunitimportsyms: entry_name:='ibunitimportsyms';
|
|
iborderedsymbols: entry_name:='iborderedsymbols';
|
|
|
|
ibmainname: entry_name:='ibmainname';
|
|
ibsymtableoptions: entry_name:='ibsymtableoptions';
|
|
// ibrecsymtableoptions: entry_name:='ibrecsymtableoptions';
|
|
ibpackagefiles: entry_name:='ibpackagefiles';
|
|
ibpackagename: entry_name:='ibpackagename';
|
|
{ target-specific things }
|
|
iblinkotherframeworks: entry_name:='iblinkotherframeworks';
|
|
ibjvmnamespace: entry_name:='ibjvmnamespace';
|
|
else
|
|
entry_name:='unknown entry '+tostr(nr);
|
|
end;
|
|
end;
|
|
|
|
procedure tentryfile.ppu_log(st :string);
|
|
begin
|
|
if flog_open then
|
|
begin
|
|
writeln(flog,bufstart+bufidx,': ',st);
|
|
end;
|
|
{$ifdef IN_PPUDUMP}
|
|
writeln(bufstart+bufidx,': ',st);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure tentryfile.inc_log_level;
|
|
begin
|
|
inc(ppu_log_level);
|
|
end;
|
|
|
|
procedure tentryfile.ppu_log_val(st :string);
|
|
begin
|
|
if flog_open then
|
|
begin
|
|
writeln(flog,'(',ppu_log_level,') value: ',st);
|
|
end;
|
|
{$ifdef IN_PPUDUMP}
|
|
writeln('(',ppu_log_level,') value: ',st);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure tentryfile.dec_log_level;
|
|
begin
|
|
dec(ppu_log_level);
|
|
end;
|
|
{$endif}
|
|
|
|
function tentryfile.getversion:integer;
|
|
var
|
|
l : integer;
|
|
code : integer;
|
|
header : pentryheader;
|
|
begin
|
|
header:=getheaderaddr;
|
|
Val(header^.ver[1]+header^.ver[2]+header^.ver[3],l,code);
|
|
if code=0 then
|
|
result:=l
|
|
else
|
|
result:=0;
|
|
end;
|
|
|
|
procedure tentryfile.flush;
|
|
begin
|
|
if mode=2 then
|
|
writebuf;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.RaiseAssertion(Code: Longint);
|
|
begin
|
|
{ It's down to descendent classes to raise an internal error as desired. [Kit] }
|
|
error := true;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.closefile;
|
|
begin
|
|
if mode<>0 then
|
|
begin
|
|
flush;
|
|
{$ifdef DEBUG_PPU}
|
|
if (entry.nr<>0) and (mode=1) then
|
|
ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
|
|
{$endif}
|
|
if fisfile then
|
|
f.Free;
|
|
mode:=0;
|
|
closed:=true;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.setposition(value:longint);
|
|
begin
|
|
if assigned(f) then
|
|
f.Position:=value
|
|
else
|
|
if tempclosed then
|
|
closepos:=value;
|
|
end;
|
|
|
|
|
|
function tentryfile.getposition:longint;
|
|
begin
|
|
if assigned(f) then
|
|
result:=f.Position
|
|
else
|
|
if tempclosed then
|
|
result:=closepos
|
|
else
|
|
result:=0;
|
|
end;
|
|
|
|
|
|
function tentryfile.substream(ofs,len:longint):TCStream;
|
|
begin
|
|
result:=nil;
|
|
if assigned(f) then
|
|
result:=TCRangeStream.Create(f,ofs,len);
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
tentryfile Reading
|
|
*****************************************************************************}
|
|
|
|
function tentryfile.openfile:boolean;
|
|
var
|
|
strm : TCStream;
|
|
begin
|
|
openfile:=false;
|
|
try
|
|
strm:=CFileStreamClass.Create(fname,fmOpenRead)
|
|
except
|
|
exit;
|
|
end;
|
|
openfile:=openstream(strm);
|
|
fisfile:=result;
|
|
end;
|
|
|
|
|
|
function tentryfile.openstream(strm:TCStream):boolean;
|
|
var
|
|
i : longint;
|
|
begin
|
|
openstream:=false;
|
|
f:=strm;
|
|
closed:=false;
|
|
{$ifdef DEBUG_PPU}
|
|
{$push}
|
|
{$I-}
|
|
assign(flog,fname+'.debug-read-log');
|
|
rewrite(flog);
|
|
if InOutRes=0 then
|
|
flog_open:=true;
|
|
{$pop}
|
|
{$endif DEBUG_PPU}
|
|
{read ppuheader}
|
|
fsize:=f.Size;
|
|
i:=readheader;
|
|
if i<0 then
|
|
exit;
|
|
{reset buffer}
|
|
bufstart:=i;
|
|
bufsize:=0;
|
|
bufidx:=0;
|
|
mode:=1;
|
|
FillChar(entry,sizeof(tentry),0);
|
|
entryidx:=0;
|
|
entrystart:=0;
|
|
entrybufstart:=0;
|
|
error:=false;
|
|
openstream:=true;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.reloadbuf;
|
|
begin
|
|
inc(bufstart,bufsize);
|
|
bufsize:=f.Read(buf^,entryfilebufsize);
|
|
bufidx:=0;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.readdata(out b;len:integer);
|
|
var
|
|
p,pbuf : pchar;
|
|
left : integer;
|
|
{$ifdef DEBUG_PPU}
|
|
i : integer;
|
|
{$endif DEBUG_PPU}
|
|
begin
|
|
p:=pchar(@b);
|
|
pbuf:=@buf[bufidx];
|
|
repeat
|
|
left:=bufsize-bufidx;
|
|
if len<left then
|
|
break;
|
|
move(pbuf^,p^,left);
|
|
dec(len,left);
|
|
inc(p,left);
|
|
reloadbuf;
|
|
pbuf:=@buf[bufidx];
|
|
if bufsize=0 then
|
|
exit;
|
|
until false;
|
|
move(pbuf^,p^,len);
|
|
{$ifdef DEBUG_PPU}
|
|
if ppu_log_level <= 0 then
|
|
begin
|
|
ppu_log('writedata, length='+tostr(len)+' level='+tostr(ppu_log_level));
|
|
for i:=0 to len-1 do
|
|
ppu_log_val('p['+tostr(i)+']=$'+hexstr(byte(p[i]),2));
|
|
end;
|
|
{$endif DEBUG_PPU}
|
|
inc(bufidx,len);
|
|
end;
|
|
|
|
procedure tentryfile.readdata(const b: TByteDynArray);
|
|
begin
|
|
ReadData(B[0],Length(B));
|
|
end;
|
|
|
|
procedure tentryfile.readdata(const b: TAnsiCharDynArray);
|
|
begin
|
|
ReadData(B[0],Length(B));
|
|
end;
|
|
|
|
|
|
procedure tentryfile.skipdata(len:integer);
|
|
var
|
|
left : integer;
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
if len>0 then
|
|
ppu_log('explicit skipdata '+tostr(len));
|
|
{$endif}
|
|
while len>0 do
|
|
begin
|
|
left:=bufsize-bufidx;
|
|
if len>left then
|
|
begin
|
|
dec(len,left);
|
|
reloadbuf;
|
|
if bufsize=0 then
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
inc(bufidx,len);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tentryfile.readentry:byte;
|
|
begin
|
|
if entryidx<entry.size then
|
|
begin
|
|
{$ifdef generic_cpu}
|
|
has_more:=true;
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
if entry.size-entryidx>0 then
|
|
ppu_log('skipdata '+tostr(entry.size-entryidx));
|
|
{$endif}
|
|
skipdata(entry.size-entryidx);
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
if entry.nr<>0 then
|
|
ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
|
|
ppu_log('entrystart');
|
|
{$endif}
|
|
readdata(entry,sizeof(tentry));
|
|
if change_endian then
|
|
entry.size:=swapendian(entry.size);
|
|
entrystart:=bufstart+bufidx;
|
|
entryidx:=0;
|
|
{$ifdef generic_cpu}
|
|
has_more:=false;
|
|
{$endif not generic_cpu}
|
|
if not(entry.id in [mainentryid,subentryid]) then
|
|
begin
|
|
readentry:=iberror;
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readentry:=entry.nr;
|
|
end;
|
|
|
|
|
|
function tentryfile.endofentry: boolean;
|
|
begin
|
|
{$ifdef generic_cpu}
|
|
endofentry:=(entryidx=entry.size);
|
|
{$else not generic_cpu}
|
|
endofentry:=(entryidx>=entry.size);
|
|
{$endif not generic_cpu}
|
|
end;
|
|
|
|
|
|
function tentryfile.entrysize:longint;
|
|
begin
|
|
entrysize:=entry.size;
|
|
end;
|
|
|
|
function tentryfile.entryleft:longint;
|
|
begin
|
|
entryleft:=entry.size-entryidx;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.getdatabuf(out b;len:integer;out res:integer);
|
|
begin
|
|
if entryidx+len>entry.size then
|
|
res:=entry.size-entryidx
|
|
else
|
|
res:=len;
|
|
readdata(b,res);
|
|
inc(entryidx,res);
|
|
end;
|
|
|
|
|
|
procedure tentryfile.getdata(out b;len:integer);
|
|
begin
|
|
if entryidx+len>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readdata(b,len);
|
|
inc(entryidx,len);
|
|
end;
|
|
|
|
procedure tentryfile.getdata(b: TByteDynArray);
|
|
begin
|
|
if entryidx+Length(b)>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readdata(b);
|
|
inc(entryidx,length(b));
|
|
end;
|
|
|
|
procedure tentryfile.getdata(b: TAnsiCharDynArray);
|
|
begin
|
|
if entryidx+Length(b)>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readdata(b);
|
|
inc(entryidx,length(b));
|
|
end;
|
|
|
|
|
|
function tentryfile.getbyte:byte;
|
|
begin
|
|
if entryidx>=entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putbyte');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufidx<bufsize then
|
|
begin
|
|
result:=pbyte(@buf[bufidx])^;
|
|
inc(bufidx);
|
|
end
|
|
else
|
|
readdata(result,1);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx);
|
|
end;
|
|
|
|
|
|
function tentryfile.getword:word;
|
|
begin
|
|
if entryidx+2>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putword');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufsize-bufidx>=sizeof(word) then
|
|
begin
|
|
result:=Unaligned(pword(@buf[bufidx])^);
|
|
inc(bufidx,sizeof(word));
|
|
end
|
|
else
|
|
readdata(result,sizeof(word));
|
|
if change_endian then
|
|
result:=swapendian(result);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,2);
|
|
end;
|
|
|
|
|
|
function tentryfile.getlongint:longint;
|
|
begin
|
|
if entryidx+4>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putlongint');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufsize-bufidx>=sizeof(longint) then
|
|
begin
|
|
result:=Unaligned(plongint(@buf[bufidx])^);
|
|
inc(bufidx,sizeof(longint));
|
|
end
|
|
else
|
|
readdata(result,sizeof(longint));
|
|
if change_endian then
|
|
result:=swapendian(result);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,4);
|
|
end;
|
|
|
|
|
|
function tentryfile.getdword:dword;
|
|
begin
|
|
if entryidx+4>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putdword');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufsize-bufidx>=sizeof(dword) then
|
|
begin
|
|
result:=Unaligned(pdword(@buf[bufidx])^);
|
|
inc(bufidx,sizeof(longint));
|
|
end
|
|
else
|
|
readdata(result,sizeof(dword));
|
|
if change_endian then
|
|
result:=swapendian(result);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,4);
|
|
end;
|
|
|
|
|
|
function tentryfile.getint64:int64;
|
|
begin
|
|
if entryidx+8>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putint64');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufsize-bufidx>=sizeof(int64) then
|
|
begin
|
|
result:=Unaligned(pint64(@buf[bufidx])^);
|
|
inc(bufidx,sizeof(int64));
|
|
end
|
|
else
|
|
readdata(result,sizeof(int64));
|
|
if change_endian then
|
|
result:=swapendian(result);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,8);
|
|
end;
|
|
|
|
|
|
function tentryfile.getqword:qword;
|
|
begin
|
|
if entryidx+8>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
exit;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putqword');
|
|
inc_log_level;
|
|
{$endif}
|
|
if bufsize-bufidx>=sizeof(qword) then
|
|
begin
|
|
result:=Unaligned(pqword(@buf[bufidx])^);
|
|
inc(bufidx,sizeof(qword));
|
|
end
|
|
else
|
|
readdata(result,sizeof(qword));
|
|
if change_endian then
|
|
result:=swapendian(result);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,8);
|
|
end;
|
|
|
|
|
|
function tentryfile.getaint:{$ifdef generic_cpu}int64{$else}aint{$endif};
|
|
{$ifdef generic_cpu}
|
|
var
|
|
header : pentryheader;
|
|
{$endif generic_cpu}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putaint');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$ifdef generic_cpu}
|
|
header:=getheaderaddr;
|
|
if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
|
|
result:=getint64
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
|
|
result:=getlongint
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
|
|
result:=smallint(getword)
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
|
|
result:=shortint(getbyte)
|
|
else
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
end;
|
|
{$else not generic_cpu}
|
|
case sizeof(aint) of
|
|
8: result:=getint64;
|
|
4: result:=getlongint;
|
|
2: result:=smallint(getword);
|
|
1: result:=shortint(getbyte);
|
|
else
|
|
begin
|
|
RaiseAssertion(2019041801);
|
|
result:=0;
|
|
end;
|
|
end;
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tentryfile.getasizeint:{$ifdef generic_cpu}int64{$else}asizeint{$endif};
|
|
{$ifdef generic_cpu}
|
|
var
|
|
header : pentryheader;
|
|
{$endif generic_cpu}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putasizeint');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$ifdef generic_cpu}
|
|
header:=getheaderaddr;
|
|
if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
|
|
result:=getint64
|
|
else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
|
|
result:=getlongint
|
|
else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
|
|
begin
|
|
{ result:=smallint(getword);
|
|
would have been logical, but it contradicts
|
|
definition of asizeint in globtype unit,
|
|
which uses 32-bit lngint type even for 16-bit
|
|
address size, to be able to cope with
|
|
I8086 seg:ofs huge addresses }
|
|
result:=getlongint;
|
|
end
|
|
else
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
end;
|
|
{$else not generic_cpu}
|
|
case sizeof(asizeint) of
|
|
8: result:=asizeint(getint64);
|
|
4: result:=asizeint(getlongint);
|
|
2: result:=asizeint(getword);
|
|
1: result:=asizeint(getbyte);
|
|
else
|
|
begin
|
|
RaiseAssertion(2019041802);
|
|
result:=0;
|
|
end;
|
|
end;
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tentryfile.getpuint:{$ifdef generic_cpu}qword{$else}puint{$endif};
|
|
{$ifdef generic_cpu}
|
|
var
|
|
header : pentryheader;
|
|
{$endif generic_cpu}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putpuint');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$ifdef generic_cpu}
|
|
header:=getheaderaddr;
|
|
if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
|
|
result:=getqword
|
|
else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=32 then
|
|
result:=getdword
|
|
else if CpuAddrBitSize[tsystemcpu(header^.cpu)]=16 then
|
|
result:=getword
|
|
else
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
end;
|
|
{$else not generic_cpu}
|
|
case sizeof(puint) of
|
|
8: result:=getqword;
|
|
4: result:=getdword;
|
|
2: result:=getword;
|
|
1: result:=getbyte;
|
|
else
|
|
begin
|
|
RaiseAssertion(2019041803);
|
|
result:=0;
|
|
end;
|
|
end;
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tentryfile.getptruint:{$ifdef generic_cpu}qword{$else}TConstPtrUInt{$endif};
|
|
{$ifdef generic_cpu}
|
|
var
|
|
header : pentryheader;
|
|
{$endif generic_cpu}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putptruint');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$ifdef generic_cpu}
|
|
header:=getheaderaddr;
|
|
if CpuAddrBitSize[tsystemcpu(header^.cpu)]=64 then
|
|
result:=getqword
|
|
else result:=getdword;
|
|
{$else not generic_cpu}
|
|
{$if sizeof(TConstPtrUInt)=8}
|
|
result:=tconstptruint(getint64);
|
|
{$else}
|
|
result:=TConstPtrUInt(getlongint);
|
|
{$endif}
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tentryfile.getaword:{$ifdef generic_cpu}qword{$else}aword{$endif};
|
|
{$ifdef generic_cpu}
|
|
var
|
|
header : pentryheader;
|
|
{$endif generic_cpu}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putaword');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$ifdef generic_cpu}
|
|
header:=getheaderaddr;
|
|
if CpuAluBitSize[tsystemcpu(header^.cpu)]=64 then
|
|
result:=getqword
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=32 then
|
|
result:=getdword
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=16 then
|
|
result:=getword
|
|
else if CpuAluBitSize[tsystemcpu(header^.cpu)]=8 then
|
|
result:=getbyte
|
|
else
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
end;
|
|
{$else not generic_cpu}
|
|
case sizeof(aword) of
|
|
8: result:=getqword;
|
|
4: result:=getdword;
|
|
2: result:=getword;
|
|
1: result:=getbyte;
|
|
else
|
|
begin
|
|
RaiseAssertion(2019041804);
|
|
result:=0;
|
|
end;
|
|
end;
|
|
{$endif not generic_cpu}
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(tostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
{ i8086,i386 and x86_64 normally have 80bit float type for
|
|
entryreal, but this is not supported
|
|
on CPUs without 80bit floats.
|
|
Special code is required to handle this. }
|
|
const
|
|
sizeof_floatx80 = 10;
|
|
type
|
|
floatx80_byte_array=array[0..sizeof_floatx80-1] of byte;
|
|
pentryreal=^entryreal;
|
|
|
|
function swapendian_floatx80entryreal(d:floatx80_byte_array):floatx80_byte_array;
|
|
var
|
|
i:0..sizeof(d)-1;
|
|
begin
|
|
for i:=low(floatx80_byte_array) to high(floatx80_byte_array) do
|
|
result[i]:=d[high(floatx80_byte_array)-i];
|
|
end;
|
|
|
|
{$endif FPC_SOFT_FPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
|
|
function tentryfile.getrealsize(sizeofreal : longint):entryreal;
|
|
var
|
|
e : entryreal;
|
|
d : double;
|
|
di : qword;{ integer of same size as double }
|
|
s : single;
|
|
si : dword; { integer of same size as single }
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
floatx80_ba : floatx80_byte_array;
|
|
floatx80_e: floatx80;
|
|
local_softfloat_exception_mask : TFPUExceptionMask;
|
|
high : word;
|
|
qlow : qword;
|
|
f64 : float64;
|
|
i:byte;
|
|
{$endif}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
begin
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
if sizeofreal=sizeof(floatx80_byte_array) then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')='));
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+sizeof(floatx80_ba)>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
readdata(floatx80_ba,sizeof(floatx80_ba));
|
|
if change_endian then
|
|
floatx80_ba:=swapendian_floatx80entryreal(floatx80_ba);
|
|
{$ifdef FPC_BIG_ENDIAN}
|
|
floatx80_e.high:=pword(@floatx80_ba[0])^;
|
|
floatx80_e.low:=pqword(@floatx80_ba[8])^;
|
|
{$else}
|
|
floatx80_e.high:=pword(@floatx80_ba[8])^;
|
|
floatx80_e.low:=pqword(@floatx80_ba[0])^;
|
|
{$endif}
|
|
local_softfloat_exception_mask:=softfloat_exception_mask;
|
|
softfloat_exception_mask:=[float_flag_invalid,float_flag_denormal,float_flag_divbyzero,float_flag_overflow,float_flag_underflow,float_flag_inexact];
|
|
f64:=floatx80_to_float64(floatx80_e);
|
|
result:=pentryreal(@f64)^;
|
|
softfloat_exception_mask:=local_softfloat_exception_mask;
|
|
inc(entryidx,sizeof(floatx80_ba));
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
{$endif FPC_SOFT_FPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
if sizeofreal=sizeof(e) then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+sizeof(e)>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
readdata(e,sizeof(e));
|
|
if change_endian then
|
|
result:=swapendian_entryreal(e)
|
|
else
|
|
result:=e;
|
|
inc(entryidx,sizeof(e));
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
if sizeofreal=sizeof(d) then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+sizeof(d)>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
readdata(d,sizeof(d));
|
|
if change_endian then
|
|
begin
|
|
di:=swapendian(pqword(@d)^);
|
|
d:=pdouble(@di)^;
|
|
end;
|
|
result:=d;
|
|
inc(entryidx,sizeof(d));
|
|
result:=d;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
if sizeofreal=sizeof(s) then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('getrealsize(sizeofreal='+tostr(sizeofreal)+')=');
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+sizeof(s)>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:=0;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
readdata(s,sizeof(s));
|
|
if change_endian then
|
|
begin
|
|
si:=swapendian(pdword(@s)^);
|
|
s:=psingle(@si)^;
|
|
end;
|
|
result:=s;
|
|
inc(entryidx,sizeof(s));
|
|
result:=s;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(realtostr(result));
|
|
dec_log_level;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
error:=true;
|
|
result:=0.0;
|
|
end;
|
|
|
|
|
|
function tentryfile.getreal:entryreal;
|
|
var
|
|
d : entryreal;
|
|
hd : double;
|
|
begin
|
|
if target_info.system=system_x86_64_win64 then
|
|
begin
|
|
hd:=getrealsize(sizeof(hd));
|
|
getreal:=hd;
|
|
end
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
else
|
|
if target_info.cpu in [cpu_i8086, cpu_i386, cpu_x86_64] then
|
|
begin
|
|
d:=getrealsize(sizeof(floatx80_byte_array));
|
|
getreal:=d;
|
|
end
|
|
{$endif def FPC_SOFT_FPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
else
|
|
begin
|
|
d:=getrealsize(sizeof(d));
|
|
getreal:=d;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tentryfile.getboolean:boolean;
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putboolean');
|
|
{$endif}
|
|
result:=boolean(getbyte);
|
|
end;
|
|
|
|
|
|
function tentryfile.getstring:string;
|
|
begin
|
|
result[0]:=chr(getbyte);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putstring,size='+tostr(length(result)+1));
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+length(result)>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
ReadData(result[1],length(result));
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(result);
|
|
dec_log_level;
|
|
{$endif}
|
|
inc(entryidx,length(result));
|
|
end;
|
|
|
|
function tentryfile.getpshortstring:pshortstring;
|
|
var
|
|
len: char;
|
|
begin
|
|
result:=nil;
|
|
len:=chr(getbyte);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putstring,size='+tostr(ord(len)+1));
|
|
inc_log_level;
|
|
{$endif}
|
|
if entryidx+ord(len)>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
getmem(result,ord(len)+1);
|
|
result^[0]:=len;
|
|
ReadData(result^[1],ord(len));
|
|
inc(entryidx,ord(len));
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(result^);
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
function tentryfile.getansistring:ansistring;
|
|
var
|
|
len: longint;
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putansistring');
|
|
inc_log_level;
|
|
{$endif}
|
|
len:=getlongint;
|
|
if entryidx+len>entry.size then
|
|
begin
|
|
error:=true;
|
|
result:='';
|
|
exit;
|
|
end;
|
|
setlength(result,len);
|
|
if len>0 then
|
|
getdata(result[1],len);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log_val(result);
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.getset(out arr: array of byte);
|
|
var
|
|
i : longint;
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putset');
|
|
inc_log_level;
|
|
{$endif}
|
|
getdata(arr,sizeof(arr));
|
|
if change_endian then
|
|
for i:=low(arr) to high(arr) do
|
|
arr[i]:=reverse_byte(arr[i]);
|
|
{$ifdef DEBUG_PPU}
|
|
for i:=low(arr) to high(arr) do
|
|
ppu_log_val('byte['+tostr(i)+']=$'+hexstr(arr[i],2));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tentryfile.skipuntilentry(untilb:byte):boolean;
|
|
var
|
|
b : byte;
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('skipuntilentry '+tostr(untilb));
|
|
{$endif}
|
|
repeat
|
|
b:=readentry;
|
|
until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
|
|
skipuntilentry:=(b=untilb);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
tentryfile Writing
|
|
*****************************************************************************}
|
|
|
|
function tentryfile.createfile:boolean;
|
|
var
|
|
ok: boolean;
|
|
strm : TCStream;
|
|
begin
|
|
createfile:=false;
|
|
strm:=nil;
|
|
if outputallowed then
|
|
begin
|
|
{$ifdef MACOS}
|
|
{FPas is FreePascal's creator code on MacOS. See systems/mac_crea.txt}
|
|
SetDefaultMacOSCreator('FPas');
|
|
SetDefaultMacOSFiletype('FPPU');
|
|
{$endif}
|
|
ok:=false;
|
|
try
|
|
strm:=CFileStreamClass.Create(fname,fmCreate);
|
|
ok:=true;
|
|
except
|
|
end;
|
|
{$ifdef MACOS}
|
|
SetDefaultMacOSCreator('MPS ');
|
|
SetDefaultMacOSFiletype('TEXT');
|
|
{$endif}
|
|
if not ok then
|
|
exit;
|
|
end;
|
|
createfile:=createstream(strm);
|
|
fisfile:=result;
|
|
end;
|
|
|
|
function tentryfile.createstream(strm:TCStream):boolean;
|
|
begin
|
|
createstream:=false;
|
|
if outputallowed then
|
|
begin
|
|
f:=strm;
|
|
mode:=2;
|
|
{write header for sure}
|
|
f.Write(getheaderaddr^,getheadersize);
|
|
end;
|
|
bufsize:=entryfilebufsize;
|
|
bufstart:=getheadersize;
|
|
bufidx:=0;
|
|
{reset}
|
|
resetfile;
|
|
error:=false;
|
|
size:=0;
|
|
entrytyp:=mainentryid;
|
|
{$ifdef DEBUG_PPU}
|
|
{$push}
|
|
{$I-}
|
|
assign(flog,fname+'.debug-write-log');
|
|
rewrite(flog);
|
|
if InOutRes=0 then
|
|
flog_open:=true;
|
|
{$pop}
|
|
{$endif DEBUG_PPU}
|
|
{start}
|
|
newentry;
|
|
createstream:=true;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.writebuf;
|
|
begin
|
|
if outputallowed and
|
|
(bufidx <> 0) then
|
|
f.Write(buf^,bufidx);
|
|
inc(bufstart,bufidx);
|
|
bufidx:=0;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.writedata(const b;len:integer);
|
|
var
|
|
p : pchar;
|
|
left,
|
|
idx : integer;
|
|
{$ifdef DEBUG_PPU}
|
|
start_len : integer;
|
|
{$endif}
|
|
begin
|
|
if not outputallowed then
|
|
exit;
|
|
{$ifdef DEBUG_PPU}
|
|
start_len:=len;
|
|
{$endif}
|
|
p:=pchar(@b);
|
|
idx:=0;
|
|
while len>0 do
|
|
begin
|
|
left:=bufsize-bufidx;
|
|
if len>left then
|
|
begin
|
|
move(p[idx],buf[bufidx],left);
|
|
dec(len,left);
|
|
inc(idx,left);
|
|
inc(bufidx,left);
|
|
writebuf;
|
|
end
|
|
else
|
|
begin
|
|
move(p[idx],buf[bufidx],len);
|
|
inc(bufidx,len);
|
|
{$ifdef DEBUG_PPU}
|
|
len:=0;
|
|
{$else}
|
|
exit;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
if (start_len > 0) and (ppu_log_level <= 0) then
|
|
begin
|
|
ppu_log('writedata, length='+tostr(start_len)+' level='+tostr(ppu_log_level));
|
|
for idx:=0 to start_len-1 do
|
|
ppu_log_val('p['+tostr(idx)+']=$'+hexstr(byte(p[idx]),2));
|
|
end;
|
|
{$endif DEBUG_PPU}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.newentry;
|
|
begin
|
|
with entry do
|
|
begin
|
|
id:=entrytyp;
|
|
nr:=ibend;
|
|
size:=0;
|
|
end;
|
|
{Reset Entry State}
|
|
entryidx:=0;
|
|
entrybufstart:=bufstart;
|
|
entrystart:=bufstart+bufidx;
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('entrystart');
|
|
{$endif}
|
|
{Alloc in buffer}
|
|
writedata(entry,sizeof(tentry));
|
|
end;
|
|
|
|
|
|
procedure tentryfile.writeentry(ibnr:byte);
|
|
var
|
|
opos : integer;
|
|
begin
|
|
{create entry}
|
|
entry.id:=entrytyp;
|
|
entry.nr:=ibnr;
|
|
entry.size:=entryidx;
|
|
{it's already been sent to disk ?}
|
|
if entrybufstart<>bufstart then
|
|
begin
|
|
if outputallowed then
|
|
begin
|
|
{flush to be sure}
|
|
WriteBuf;
|
|
{write entry}
|
|
opos:=f.Position;
|
|
f.Position:=entrystart;
|
|
f.write(entry,sizeof(tentry));
|
|
f.Position:=opos;
|
|
end;
|
|
entrybufstart:=bufstart;
|
|
end
|
|
else
|
|
move(entry,buf[entrystart-bufstart],sizeof(entry));
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('writeentry, id='+entryid_name(entry.id)+' nr='+entry_name(entry.nr)+' size='+tostr(entry.size));
|
|
{$endif}
|
|
{Add New Entry, which is ibend by default}
|
|
entrystart:=bufstart+bufidx; {next entry position}
|
|
newentry;
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putdata(const b;len:integer);
|
|
begin
|
|
if outputallowed then
|
|
writedata(b,len);
|
|
inc(entryidx,len);
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putbyte(b:byte);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putbyte');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(b));
|
|
{$endif}
|
|
putdata(b,1);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putword(w:word);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putword');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(w));
|
|
{$endif}
|
|
putdata(w,2);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putdword(w:dword);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putdword');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(w));
|
|
{$endif}
|
|
putdata(w,4);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putlongint(l:longint);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putlongint');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(l));
|
|
{$endif}
|
|
putdata(l,4);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putint64(i:int64);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putint64');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(i));
|
|
{$endif}
|
|
putdata(i,8);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putqword(q:qword);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putqword');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(q));
|
|
{$endif}
|
|
putdata(q,sizeof(qword));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putaint(i:aint);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putaint');
|
|
inc_log_level;
|
|
case sizeof(aint) of
|
|
8: ppu_log('putint64');
|
|
4: ppu_log('putlongint');
|
|
2: ppu_log('putword');
|
|
1: ppu_log('putbyte');
|
|
end;
|
|
ppu_log_val(tostr(i));
|
|
{$endif}
|
|
putdata(i,sizeof(aint));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putasizeint(i: asizeint);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putasizeint');
|
|
inc_log_level;
|
|
case sizeof(asizeint) of
|
|
8: ppu_log('putint64');
|
|
4: ppu_log('putlongint');
|
|
2: ppu_log('putword');
|
|
1: ppu_log('putbyte');
|
|
end;
|
|
ppu_log_val(tostr(i));
|
|
{$endif}
|
|
putdata(i,sizeof(asizeint));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putpuint(i : puint);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putpuint');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(i));
|
|
{$endif}
|
|
putdata(i,sizeof(puint));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
procedure tentryfile.putptruint(v:TConstPtrUInt);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putptruint');
|
|
inc_log_level;
|
|
{$endif}
|
|
{$if sizeof(TConstPtrUInt)=8}
|
|
putint64(int64(v));
|
|
{$else}
|
|
putlongint(longint(v));
|
|
{$endif}
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
|
|
|
|
procedure tentryfile.putaword(i:aword);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putaword');
|
|
inc_log_level;
|
|
ppu_log_val(tostr(i));
|
|
{$endif}
|
|
putdata(i,sizeof(aword));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putreal(d:entryreal);
|
|
var
|
|
hd : double;
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
floatx80_ba : floatx80_byte_array;
|
|
floatx80_e : floatx80;
|
|
f64 : float64;
|
|
local_softfloat_exception_mask : TFPUExceptionMask;
|
|
i:byte;
|
|
{$endif FPC_SOFT_FFPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
begin
|
|
if target_info.system=system_x86_64_win64 then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putreal,size='+tostr(sizeof(hd)));
|
|
inc_log_level;
|
|
ppu_log_val(realtostr(d));
|
|
{$endif}
|
|
hd:=d;
|
|
putdata(hd,sizeof(hd));
|
|
end
|
|
{$ifndef FPC_HAS_TYPE_EXTENDED}
|
|
{$ifdef FPC_SOFT_FPUX80}
|
|
else if target_info.cpu in [cpu_i8086, cpu_i386, cpu_x86_64] then
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putreal,size='+tostr(sizeof(floatx80_e)));
|
|
inc_log_level;
|
|
{$endif}
|
|
local_softfloat_exception_mask:=softfloat_exception_mask;
|
|
softfloat_exception_mask:=[float_flag_invalid,float_flag_denormal,float_flag_divbyzero,float_flag_overflow,float_flag_underflow,float_flag_inexact];
|
|
f64:=float64(d);
|
|
floatx80_e:=float64_to_floatx80(f64);
|
|
softfloat_exception_mask:=local_softfloat_exception_mask;
|
|
{$ifdef FPC_BIG_ENDIAN}
|
|
pword(@floatx80_ba[0])^:=floatx80_e.high;
|
|
unaligned(pqword(@floatx80_ba[2])^):=floatx80_e.low;
|
|
{$else}
|
|
pword(@floatx80_ba[8])^:=floatx80_e.high;
|
|
pqword(@floatx80_ba[0])^:=floatx80_e.low;
|
|
{$endif}
|
|
putdata(floatx80_ba,sizeof(floatx80_ba));
|
|
end
|
|
{$endif FPC_SOFT_FPUX80}
|
|
{$endif ndef FPC_HAS_TYPE_EXTENDED}
|
|
else
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putreal,size='+tostr(sizeof(d)));
|
|
inc_log_level;
|
|
ppu_log_val(realtostr(d));
|
|
{$endif}
|
|
putdata(d,sizeof(entryreal));
|
|
end;
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putboolean(b:boolean);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putboolean');
|
|
inc_log_level;
|
|
{$endif}
|
|
putbyte(byte(b));
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putstring(const s:string);
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
{ The reading method uses getbyte, so fake it here }
|
|
ppu_log('putbyte');
|
|
inc_log_level;
|
|
inc(bufidx);
|
|
ppu_log('putstring,size='+tostr(length(s)+1));
|
|
dec(bufidx);
|
|
ppu_log_val(s);
|
|
{$endif}
|
|
putdata(s,length(s)+1);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putansistring(const s:ansistring);
|
|
var
|
|
len: longint;
|
|
begin
|
|
len:=length(s);
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putansistring');
|
|
inc_log_level;
|
|
ppu_log_val(s);
|
|
{$endif}
|
|
putlongint(len);
|
|
if len>0 then
|
|
putdata(s[1],len);
|
|
{$ifdef DEBUG_PPU}
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.putset(const arr: array of byte);
|
|
{$ifdef DEBUG_PPU}
|
|
var
|
|
i : byte;
|
|
{$endif}
|
|
begin
|
|
{$ifdef DEBUG_PPU}
|
|
ppu_log('putset');
|
|
inc_log_level;
|
|
{$endif}
|
|
putdata(arr,sizeof(arr));
|
|
{$ifdef DEBUG_PPU}
|
|
for i:=0 to sizeof(arr)-1 do
|
|
ppu_log_val('byte['+tostr(i)+']=$'+hexstr(arr[i],2));
|
|
dec_log_level;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure tentryfile.tempclose;
|
|
begin
|
|
if not closed then
|
|
begin
|
|
closepos:=f.Position;
|
|
f.Free;
|
|
f:=nil;
|
|
closed:=true;
|
|
tempclosed:=true;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tentryfile.tempopen:boolean;
|
|
begin
|
|
tempopen:=false;
|
|
if not closed or not tempclosed then
|
|
exit;
|
|
{ MG: not sure, if this is correct
|
|
f.position:=0;
|
|
No, f was freed in tempclose above, we need to
|
|
recreate it. PM 2011/06/06 }
|
|
try
|
|
f:=CFileStreamClass.Create(fname,fmOpenRead);
|
|
except
|
|
exit;
|
|
end;
|
|
closed:=false;
|
|
tempclosed:=false;
|
|
|
|
{ restore state }
|
|
f.Position:=closepos;
|
|
tempopen:=true;
|
|
end;
|
|
|
|
end.
|