paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-02 09:03:41 +02:00
Code Issues Packages Projects Releases Wiki Activity
bf8fe9c2a9
lazarus/components/codetools/ppuparser.pas

1918 lines
53 KiB
ObjectPascal
Raw Blame History

{
***************************************************************************
* *
* This source 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 code 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. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Note:
This unit will be moved to the FCL when it has stabilized.
Abstract:
Functions and classes to read ppu streams (Free Pascal compiled units)
of various versions. For example reading 2.3.1 ppus compiled for 64bit
with a lazarus compiled with fpc 2.2.2 i386.
}
unit PPUParser;
{$mode objfpc}{$H+}
{off $DEFINE VerbosePPUParser}
interface
uses
Classes, SysUtils, FileProcs;
const
PPUIsEndianBig = {$IFDEF ENDIAN_BIG}True{$ELSE}False{$ENDIF};
const
{ppu entries}
mainentryid = 1;
subentryid = 2;
{special}
iberror = 0;
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;
// ibendsymtablebrowser = 14;
// ibbeginsymtablebrowser = 15;
ibusedmacros = 16;
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;
// ibrttisym = 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;
{implementation/ObjData}
ibnodetree = 80;
ibasmsymbols = 81;
ibresources = 82;
ibmainname = 90;
{ target-specific things }
iblinkotherframeworks = 100;
{ unit flags }
uf_init = $1;
uf_finalize = $2;
uf_big_endian = $4;
// uf_has_browser = $10;
uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
uf_smart_linked = $40; { the ppu can be smartlinked }
uf_static_linked = $80; { the ppu can be linked static }
uf_shared_linked = $100; { the ppu can be linked shared }
// uf_local_browser = $200;
uf_no_link = $400; { unit has no .o generated, but can still have
external linking! }
uf_has_resourcestrings = $800; { unit has resource string section }
uf_little_endian = $1000;
uf_release = $2000; { unit was compiled with -Ur option }
uf_threadvars = $4000; { unit has threadvars }
uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
uf_has_debuginfo = $10000; { this unit has debuginfo generated }
uf_local_symtable = $20000; { this unit has a local symtable stored }
uf_uses_variants = $40000; { this unit uses variants }
uf_has_resourcefiles = $80000; { this unit has external resources (using $R directive)}
uf_has_exports = $100000; { this module or a used unit has exports }
type
tproccalloption=(
pocall_none,
{ procedure uses C styled calling }
pocall_cdecl,
{ C++ calling conventions }
pocall_cppdecl,
{ Far16 for OS/2 }
pocall_far16,
{ Old style FPC default calling }
pocall_oldfpccall,
{ Procedure has compiler magic}
pocall_internproc,
{ procedure is a system call, applies e.g. to MorphOS and PalmOS }
pocall_syscall,
{ pascal standard left to right }
pocall_pascal,
{ procedure uses register (fastcall) calling }
pocall_register,
{ safe call calling conventions }
pocall_safecall,
{ procedure uses stdcall call }
pocall_stdcall,
{ Special calling convention for cpus without a floating point
unit. Floating point numbers are passed in integer registers
instead of floating point registers. Depending on the other
available calling conventions available for the cpu
this replaces either pocall_fastcall or pocall_stdcall.
}
pocall_softfloat,
{ Metrowerks Pascal. Special case on Mac OS (X): passes all }
{ constant records by reference. }
pocall_mwpascal
);
tproccalloptions = set of tproccalloption;
tproctypeoption=(
potype_none,
potype_proginit, { Program initialization }
potype_unitinit, { unit initialization }
potype_unitfinalize, { unit finalization }
potype_constructor, { Procedure is a constructor }
potype_destructor, { Procedure is a destructor }
potype_operator, { Procedure defines an operator }
potype_procedure,
potype_function
);
tproctypeoptions = set of tproctypeoption;
tprocoption=(
po_none,
po_classmethod, { class method }
po_virtualmethod, { Procedure is a virtual method }
po_abstractmethod, { Procedure is an abstract method }
po_staticmethod, { static method }
po_overridingmethod, { method with override directive }
po_methodpointer, { method pointer, only in procvardef, also used for 'with object do' }
po_interrupt, { Procedure is an interrupt handler }
po_iocheck, { IO checking should be done after a call to the procedure }
po_assembler, { Procedure is written in assembler }
po_msgstr, { method for string message handling }
po_msgint, { method for int message handling }
po_exports, { Procedure has export directive (needed for OS/2) }
po_external, { Procedure is external (in other object or lib)}
po_overload, { procedure is declared with overload directive }
po_varargs, { printf like arguments }
po_internconst, { procedure has constant evaluator intern }
{ flag that only the address of a method is returned and not a full methodpointer }
po_addressonly,
{ procedure is exported }
po_public,
{ calling convention is specified explicitly }
po_hascallingconvention,
{ reintroduce flag }
po_reintroduce,
{ location of parameters is given explicitly as it is necessary for some syscall
conventions like that one of MorphOS }
po_explicitparaloc,
{ no stackframe will be generated, used by lowlevel assembler like get_frame }
po_nostackframe,
po_has_mangledname,
po_has_public_name,
po_forward,
po_global,
po_has_inlininginfo,
{ The different kind of syscalls on MorphOS }
po_syscall_legacy,
po_syscall_sysv,
po_syscall_basesysv,
po_syscall_sysvbase,
po_syscall_r12base,
po_local,
{ Procedure can be inlined }
po_inline,
{ Procedure is used for internal compiler calls }
po_compilerproc,
{ importing }
po_has_importdll,
po_has_importname,
po_kylixlocal
);
tprocoptions = set of tprocoption;
const
proccalloptionNames : array[tproccalloption] of string[14]=(
'',
'CDecl',
'CPPDecl',
'Far16',
'OldFPCCall',
'InternProc',
'SysCall',
'Pascal',
'Register',
'SafeCall',
'StdCall',
'SoftFloat',
'MWPascal'
);
proctypeoptionNames : array[tproctypeoption] of string[14]=(
'none',
'proginit', { Program initialization }
'unitinit', { unit initialization }
'unitfinalize', { unit finalization }
'constructor', { Procedure is a constructor }
'destructor', { Procedure is a destructor }
'operator', { Procedure defines an operator }
'procedure',
'function'
);
procoptionNames : array[tprocoption] of string[20]=(
'none',
'classmethod', { class method }
'virtualmethod', { Procedure is a virtual method }
'abstractmethod', { Procedure is an abstract method }
'staticmethod', { static method }
'overridingmethod', { method with override directive }
'methodpointer', { method pointer, only in procvardef, also used for 'with object do' }
'interrupt', { Procedure is an interrupt handler }
'iocheck', { IO checking should be done after a call to the procedure }
'assembler', { Procedure is written in assembler }
'msgstr', { method for string message handling }
'msgint', { method for int message handling }
'exports', { Procedure has export directive (needed for OS/2) }
'external', { Procedure is external (in other object or lib)}
'overload', { procedure is declared with overload directive }
'varargs', { printf like arguments }
'internconst', { procedure has constant evaluator intern }
{ flag that only the address of a method is returned and not a full methodpointer }
'addressonly',
{ procedure is exported }
'public',
{ calling convention is specified explicitly }
'hascallingconvention',
{ reintroduce flag }
'reintroduce',
{ location of parameters is given explicitly as it is necessary for some syscall
conventions like that one of MorphOS }
'explicitparaloc',
{ no stackframe will be generated, used by lowlevel assembler like get_frame }
'nostackframe',
'has_mangledname',
'has_public_name',
'forward',
'global',
'has_inlininginfo',
{ The different kind of syscalls on MorphOS }
'syscall_legacy',
'syscall_sysv',
'syscall_basesysv',
'syscall_sysvbase',
'syscall_r12base',
'local',
{ Procedure can be inlined }
'inline',
{ Procedure is used for internal compiler calls }
'compilerproc',
{ importing }
'has_importdll',
'has_importname',
'kylixlocal'
);
type
tsymoption=(
sp_none,
sp_public,
sp_private,
sp_published,
sp_protected,
sp_static,
sp_hint_deprecated,
sp_hint_platform,
sp_hint_library,
sp_hint_unimplemented,
sp_has_overloaded,
sp_internal { internal symbol, not reported as unused }
);
tsymoptions=set of tsymoption;
const
symoptionNames : array[tsymoption] of string[20]=(
'?',
'Public',
'Private',
'Published',
'Protected',
'Static',
'Hint Deprecated',
'Hint Platform',
'Hint Library',
'Hint Unimplemented',
'Has overloaded',
'Internal'
);
type
{ flags for a definition }
tdefoption=(
df_none,
{ type is unique, i.e. declared with type = type <tdef>; }
df_unique,
{ type is a generic }
df_generic,
{ type is a specialization of a generic type }
df_specialization
);
tdefoptions=set of tdefoption;
tdefstate=(
ds_none,
ds_vmt_written,
ds_rtti_table_used,
ds_init_table_used,
ds_rtti_table_written,
ds_init_table_written,
ds_dwarf_dbg_info_used,
ds_dwarf_dbg_info_written
);
tdefstates=set of tdefstate;
const
defoptionNames : array[tdefoption] of string=(
'?',
'Unique Type',
'Generic',
'Specialization'
);
defstateNames : array[tdefstate] of string=(
'?',
'VMT Written',
'RTTITable Used',
'InitTable Used',
'RTTITable Written',
'InitTable Written',
'Dwarf DbgInfo Used',
'Dwarf DbgInfo Written'
);
type
TPPUPart = (
ppInterfaceHeader,
ppInterfaceDefinitions,
ppInterfaceSymbols,
ppInterfaceMacros,
ppImplementationHeader,
ppImplementationDefinitions,
ppImplementationSymbols
);
TPPUParts = set of TPPUPart;
const
PPUPartsAll = [low(TPPUPart)..high(TPPUPart)];
const
PPU_ID = 'PPU';
PPU_ID_Size = 3;
PPU_Ver_Size = 3;
type
TPPUHeader = packed record
id : array[1..PPU_ID_Size] of char; { = 'PPU' }
ver : array[1..PPU_Ver_Size] of char;
compiler : word;
cpu : word;
target : word;
flags : longint;
size : longint; { size of the ppufile without header }
checksum : cardinal; { checksum for this ppufile }
interface_checksum : cardinal;
deflistsize,
symlistsize : longint;
future : array[0..0] of longint;
end;
TPPUEntry = packed record
size : longint; // number of bytes following directly behind the entry
id : byte;
nr : byte;
end;
PPPUEntry = ^TPPUEntry;
{ EPPUParserError }
EPPUParserError = class(Exception)
end;
{ TPPU }
TPPU = class
private
fChangeEndian: boolean;
FHeader: TPPUHeader;
FEntry: TPPUEntry;
FEntryStart: integer;
FEntryPos: integer;
FEntryBuf: Pointer;
FEntryBufSize: integer;
FVersion: integer;
FDerefData: PByte;
FDerefDataSize: integer;
FData: Pointer;
FDataPos: integer;
FDataSize: integer;
FMainUsesSectionPos: integer;// start of the ibloadunit entry
FImplementationUsesSectionPos: integer;// start of the ibloadunit entry
FInitProcPos: integer;// start of the ibprocdef entry
FFinalProcPos: integer;// start of the ibprocdef entry
procedure ReadPPU(const Parts: TPPUParts);
procedure ReadHeader;
procedure ReadInterfaceHeader;
procedure ReadImplementationHeader;
function ReadEntry: byte;
function EndOfEntry: boolean;
procedure SkipUntilEntry(EntryNr: byte);
procedure ReadDataFromStream(s: TStream);
procedure ReadData(var Buf; Count: longint);
function ReadEntryByte: byte;
function ReadEntryByte(const Msg: string): byte;
function ReadEntryShortstring: shortstring;
function ReadEntryShortstring(const Msg: string): shortstring;
function ReadEntryLongint: longint;
function ReadEntryLongint(const Msg: string): longint;
function ReadEntryWord: word;
function ReadEntryWord(const Msg: string): word;
procedure ReadEntrySmallSet(var s);
procedure ReadEntryNormalSet(var s);
procedure ReadUsedUnits;
procedure ReadLinkContainer(Nr: byte);
procedure ReadImportSymbols;
procedure ReadDerefData;
procedure ReadDerefMap;
procedure ReadDereference;
procedure ReadPosInfo;
procedure ReadDefinitions;
procedure ReadSymbols;
procedure ReadNodeTree;
procedure ReadCommonDefinition;
procedure ReadAbstractProcDef(out proccalloption: tproccalloption;
out procoptions: tprocoptions;
out proctypeoption: tproctypeoption);
procedure ReadSymOptions;
procedure Skip(Count: integer);
procedure Error(const Msg: string);
procedure GetUsesSection(StartPos: integer; var List: TStrings);
procedure SetDataPos(NewPos: integer);
function GetProcMangledName(ProcDefPos: integer): string;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure LoadFromStream(s: TStream; const Parts: TPPUParts = PPUPartsAll);
procedure LoadFromFile(const Filename: string; const Parts: TPPUParts = PPUPartsAll);
procedure Dump(const Prefix: string = '');
procedure DumpHeader(const Prefix: string = '');
procedure GetMainUsesSectionNames(var List: TStrings);
procedure GetImplementationUsesSectionNames(var List: TStrings);
function GetInitProcName: string;
function GetFinalProcName: string;
end;
function PPUTargetToStr(w: longint): string;
function PPUCpuToStr(w: longint): string;
function PPUFlagsToStr(flags: longint): string;
function PPUTimeToStr(t: longint): string;
implementation
function reverse_byte(b: byte): byte;
const
reverse_nible: array[0..15] of 0..15 =
(%0000,%1000,%0100,%1100,%0010,%1010,%0110,%1110,
%0001,%1001,%0101,%1101,%0011,%1011,%0111,%1111);
begin
Result:=(reverse_nible[b and $f] shl 4) or reverse_nible[b shr 4];
end;
function PPUTargetToStr(w: longint): string;
type
{ taken from systems.pas }
ttarget =
(
target_none, { 0 }
target_i386_GO32V1, { 1 }
target_i386_GO32V2, { 2 }
target_i386_linux, { 3 }
target_i386_OS2, { 4 }
target_i386_Win32, { 5 }
target_i386_freebsd, { 6 }
target_m68k_Amiga, { 7 }
target_m68k_Atari, { 8 }
target_m68k_Mac, { 9 }
target_m68k_linux, { 10 }
target_m68k_PalmOS, { 11 }
target_alpha_linux, { 12 }
target_powerpc_linux, { 13 }
target_powerpc_macos, { 14 }
target_i386_sunos, { 15 }
target_i386_beos, { 16 }
target_i386_netbsd, { 17 }
target_m68k_netbsd, { 18 }
target_i386_Netware, { 19 }
target_i386_qnx, { 20 }
target_i386_wdosx, { 21 }
target_sparc_sunos, { 22 }
target_sparc_linux, { 23 }
target_i386_openbsd, { 24 }
target_m68k_openbsd, { 25 }
system_x86_64_linux, { 26 }
system_powerpc_macosx, { 27 }
target_i386_emx, { 28 }
target_powerpc_netbsd, { 29 }
target_powerpc_openbsd, { 30 }
target_arm_linux, { 31 }
target_i386_watcom, { 32 }
target_powerpc_MorphOS, { 33 }
target_x86_64_freebsd, { 34 }
target_i386_netwlibc, { 35 }
system_powerpc_Amiga, { 36 }
system_x86_64_win64, { 37 }
system_arm_wince, { 38 }
system_ia64_win64, { 39 }
system_i386_wince, { 40 }
system_x86_6432_linux, { 41 }
system_arm_gba, { 42 }
system_arm_nds { 43 }
);
const
Targets : array[ttarget] of string[17]=(
{ 0 } 'none',
{ 1 } 'GO32V1',
{ 2 } 'GO32V2',
{ 3 } 'Linux-i386',
{ 4 } 'OS/2',
{ 5 } 'Win32',
{ 6 } 'FreeBSD-i386',
{ 7 } 'Amiga',
{ 8 } 'Atari',
{ 9 } 'MacOS-m68k',
{ 10 } 'Linux-m68k',
{ 11 } 'PalmOS-m68k',
{ 12 } 'Linux-alpha',
{ 13 } 'Linux-ppc',
{ 14 } 'MacOS-ppc',
{ 15 } 'Solaris-i386',
{ 16 } 'BeOS-i386',
{ 17 } 'NetBSD-i386',
{ 18 } 'NetBSD-m68k',
{ 19 } 'Netware-i386-clib',
{ 20 } 'Qnx-i386',
{ 21 } 'WDOSX-i386',
{ 22 } 'Solaris-sparc',
{ 23 } 'Linux-sparc',
{ 24 } 'OpenBSD-i386',
{ 25 } 'OpenBSD-m68k',
{ 26 } 'Linux-x86-64',
{ 27 } 'MacOSX-ppc',
{ 28 } 'OS/2 via EMX',
{ 29 } 'NetBSD-powerpc',
{ 30 } 'OpenBSD-powerpc',
{ 31 } 'Linux-arm',
{ 32 } 'Watcom-i386',
{ 33 } 'MorphOS-powerpc',
{ 34 } 'FreeBSD-x86-64',
{ 35 } 'Netware-i386-libc',
{ 36 } 'Amiga-PowerPC',
{ 37 } 'Win64-x64',
{ 38 } 'WinCE-ARM',
{ 39 } 'Win64-iA64',
{ 40 } 'WinCE-i386',
{ 41 } 'Linux-x64',
{ 42 } 'GBA-arm',
{ 43 } 'NDS-arm'
);
begin
if w<=ord(high(ttarget)) then
Result:=Targets[ttarget(w)]
else
Result:='<!! Unknown target value '+IntToStr(w)+'>';
end;
function PPUCpuToStr(w:longint):string;
type
{ Copied from systems.pas }
tsystemcpu=
(
cpu_no, { 0 }
cpu_i386, { 1 }
cpu_m68k, { 2 }
cpu_alpha, { 3 }
cpu_powerpc, { 4 }
cpu_sparc, { 5 }
cpu_vm, { 6 }
cpu_iA64, { 7 }
cpu_x86_64, { 8 }
cpu_mips, { 9 }
cpu_arm { 10 }
);
const
CpuTxt : array[tsystemcpu] of string[8]=
('none','i386','m68k','alpha','powerpc','sparc','vis','ia64','x86_64','mips','arm');
begin
if w<=ord(high(tsystemcpu)) then
Result:=CpuTxt[tsystemcpu(w)]
else
Result:='<!! Unknown cpu value '+IntToStr(w)+'>';
end;
function PPUFlagsToStr(flags:longint):string;
type
tflagopt=record
mask : longint;
str : string[30];
end;
const
flagopts=17;
flagopt : array[1..flagopts] of tflagopt=(
(mask: $1 ;str:'init'),
(mask: $2 ;str:'final'),
(mask: $4 ;str:'big_endian'),
(mask: $8 ;str:'dbx'),
// (mask: $10 ;str:'browser'),
(mask: $20 ;str:'in_library'),
(mask: $40 ;str:'smart_linked'),
(mask: $80 ;str:'static_linked'),
(mask: $100 ;str:'shared_linked'),
// (mask: $200 ;str:'local_browser'),
(mask: $400 ;str:'no_link'),
(mask: $800 ;str:'has_resources'),
(mask: $1000 ;str:'little_endian'),
(mask: $2000 ;str:'release'),
(mask: $4000 ;str:'local_threadvars'),
(mask: $8000 ;str:'fpu_emulation_on'),
(mask: $10000 ;str:'has_debug_info'),
(mask: $20000 ;str:'local_symtable'),
(mask: $40000 ;str:'uses_variants')
);
var
i : longint;
first : boolean;
s : string;
begin
s:='';
if flags<>0 then
begin
first:=true;
for i:=1to flagopts do
if (flags and flagopt[i].mask)<>0 then
begin
if first then
first:=false
else
s:=s+', ';
s:=s+flagopt[i].str;
end;
end
else
s:='none';
Result:=s;
end;
function L0(l: longint): shortstring;
{
return the string of value l, if l<10 then insert a zero, so
the string is always at least 2 chars '01','02',etc
}
var
s : shortstring;
begin
Str(l,s);
if l<10 then
s:='0'+s;
Result:=s;
end;
function PPUTimeToStr(t: longint): string;
{
convert dos datetime t to a string YY/MM/DD HH:MM:SS
}
var
DT: TDateTime;
hsec: word;
Year, Month, Day: Word;
hour, min, sec: word;
begin
if t=-1 then
begin
Result := '<invalid time>';
exit;
end;
DT := FileDateToDateTime(t);
DecodeTime(DT,hour,min,sec,hsec);
DecodeDate(DT,year,month,day);
Result := L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
end;
{ TPPU }
procedure TPPU.ReadPPU(const Parts: TPPUParts);
begin
ReadHeader;
// interface header
if ppInterfaceHeader in Parts then
ReadInterfaceHeader
else
SkipUntilEntry(ibendinterface);
// interface definitions
if ppInterfaceDefinitions in Parts then
ReadDefinitions
else
SkipUntilEntry(ibenddefs);
// Interface Symbols
SkipUntilEntry(ibendsyms);
// Interface Macros
if ReadEntry<>ibexportedmacros then
Error('missing exported macros');
if boolean(ReadEntryByte) then begin
// skip the definition section for macros (since they are never used)
SkipUntilEntry(ibenddefs);
// read the macro symbols
SkipUntilEntry(ibendsyms);
end else begin
// no macros
end;
// Implementation Header
if ppImplementationHeader in Parts then
ReadImplementationHeader
else
SkipUntilEntry(ibendimplementation);
// Implementation Definitions and Symbols
if (FHeader.flags and uf_local_symtable)<>0 then begin
if ppImplementationDefinitions in Parts then
ReadDefinitions
else
SkipUntilEntry(ibenddefs);
SkipUntilEntry(ibendsyms);
end else begin
// no definitions and no symbols
end;
end;
procedure TPPU.ReadHeader;
begin
fChangeEndian:=PPUIsEndianBig;
// read ID
ReadData(FHeader.id,PPU_ID_Size);
if String(FHeader.id)<>PPU_ID then
Error('This is not a PPU. Wrong ID.');
// read version
ReadData(FHeader.ver,PPU_Ver_Size);
FVersion:=StrToIntDef(String(FHeader.ver),0);
if FVersion<16 then
Error('Old PPU versions (<16) are not supported.');
// read rest of header
ReadData(FHeader.compiler,SizeOf(TPPUHeader)-PPU_Ver_Size-PPU_ID_Size);
if fChangeEndian then begin
fHeader.compiler := swapendian(fHeader.compiler);
fHeader.cpu := swapendian(fHeader.cpu);
fHeader.target := swapendian(fHeader.target);
fHeader.flags := swapendian(fHeader.flags);
fHeader.size := swapendian(fHeader.size);
fHeader.checksum := swapendian(fHeader.checksum);
fHeader.interface_checksum := swapendian(fHeader.interface_checksum);
fHeader.deflistsize := swapendian(fHeader.deflistsize);
fHeader.symlistsize := swapendian(fHeader.symlistsize);
end;
fChangeEndian:=((FHeader.flags and uf_big_endian) = uf_big_endian)<>PPUIsEndianBig;
FEntryPos:=0;
FillByte(FEntry,SizeOf(FEntry),0);
{$IFDEF VerbosePPUParser}
DumpHeader('');
{$ENDIF}
end;
procedure TPPU.ReadInterfaceHeader;
var
EntryNr: Byte;
{$IFDEF VerbosePPUParser}
ModuleName: ShortString;
Filename: ShortString;
FileTime: LongInt;
Conditional: ShortString;
DefinedAtStartUp: Boolean;
IsUsed: Boolean;
{$ENDIF}
begin
repeat
EntryNr:=ReadEntry;
//DebugLn(['TPPU.ReadInterface EntryNr=',EntryNr]);
case EntryNr of
ibmodulename:
begin
{$IFDEF VerbosePPUParser}ModuleName:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadInterfaceHeader ModuleName=',ModuleName]);
{$ENDIF}
end;
ibsourcefiles:
begin
while not EndOfEntry do
begin
{$IFDEF VerbosePPUParser}Filename:={$ENDIF}ReadEntryShortstring;// filename
{$IFDEF VerbosePPUParser}FileTime:={$ENDIF}ReadEntryLongint;// file time
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadInterfaceHeader SourceFile=',Filename,' Time=',PPUTimeToStr(FileTime)]);
{$ENDIF}
end;
end;
ibloadunit:
begin
FMainUsesSectionPos:=FEntryStart;
ReadUsedUnits;
end;
iblinkunitofiles,iblinkunitstaticlibs,iblinkunitsharedlibs,
iblinkotherofiles,iblinkotherstaticlibs,iblinkothersharedlibs:
ReadLinkContainer(EntryNr);
ibImportSymbols:
ReadImportSymbols;
ibusedmacros:
begin
while not EndOfEntry do
begin
{$IFDEF VerbosePPUParser}Conditional:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}DefinedAtStartUp:=boolean(ReadEntryByte){$ELSE}ReadEntryByte{$ENDIF};
{$IFDEF VerbosePPUParser}IsUsed:=boolean(ReadEntryByte){$ELSE}ReadEntryByte{$ENDIF};
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadInterfaceHeader Macro=',Conditional,' DefinedAtStartUp=',DefinedAtStartUp,' Used=',IsUsed]);
{$ENDIF}
end;
end;
ibderefdata:
ReadDerefData;
ibderefmap:
ReadDerefMap;
ibendinterface:
break;
else
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadInterfaceHeader Skipping unsupported entry ',EntryNr]);
{$ENDIF}
FEntryPos:=FEntry.size;
end;
until false;
end;
procedure TPPU.ReadImplementationHeader;
var
EntryNr: Byte;
begin
repeat
EntryNr:=ReadEntry;
case EntryNr of
// ToDo: ibasmsymbols
ibloadunit:
begin
FImplementationUsesSectionPos:=FEntryStart;
ReadUsedUnits;
end;
ibendimplementation:
break;
else
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadImplementationHeader Skipping unsupported entry ',EntryNr]);
{$ENDIF}
FEntryPos:=FEntry.size;
end;
until false;
end;
procedure TPPU.ReadDefinitions;
type
tsettype = (normset,smallset,varset);
tordtype = (
uvoid,
u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit,
bool8bit,bool16bit,bool32bit,bool64bit,
uchar,uwidechar,scurrency
);
tobjecttyp = (odt_none,
odt_class,
odt_object,
odt_interfacecom,
odt_interfacecorba,
odt_cppclass,
odt_dispinterface
);
tvarianttype = (
vt_normalvariant,vt_olevariant
);
tprocinfoflag=(
{# procedure uses asm }
pi_uses_asm,
{# procedure does a call }
pi_do_call,
{# procedure has a try statement = no register optimization }
pi_uses_exceptions,
{# procedure is declared as @var(assembler), don't optimize}
pi_is_assembler,
{# procedure contains data which needs to be finalized }
pi_needs_implicit_finally
);
tprocinfoflags=set of tprocinfoflag;
tsystemcpu=
(
cpu_no, { 0 }
cpu_i386, { 1 }
cpu_m68k, { 2 }
cpu_alpha, { 3 }
cpu_powerpc, { 4 }
cpu_sparc, { 5 }
cpu_vm, { 6 }
cpu_iA64, { 7 }
cpu_x86_64, { 8 }
cpu_mips, { 9 }
cpu_arm { 10 }
);
var
EntryNr: Byte;
calloption: tproccalloption;
procoptions: tprocoptions;
procinfooptions : tprocinfoflag;
proctypeoption: tproctypeoption;
CurEntryStart: LongInt;
begin
if ReadEntry<>ibstartdefs then
begin
Error('missing definitions');
end;
repeat
EntryNr:=ReadEntry;
CurEntryStart:=FEntryStart;
case EntryNr of
ibpointerdef:
begin
{$IFDEF VerbosePPUParser} DebugLn(['TPPU.ReadDefinitions Pointer definition:']); {$ENDIF}
ReadCommonDefinition;
{$IFDEF VerbosePPUParser} DebugLn(['TPPU.ReadDefinitions Pointed type:']); {$ENDIF}
ReadDereference;
ReadEntryByte{$IFDEF VerbosePPUParser}('IsFar='){$ENDIF}; // is Far
end;
ibprocdef:
begin
{$IFDEF VerbosePPUParser} DebugLn(['TPPU.ReadDefinitions Procedure definition:']); {$ENDIF}
ReadCommonDefinition;
ReadAbstractProcDef(calloption,procoptions,proctypeoption);
if proctypeoption in [potype_proginit,potype_unitinit] then
FInitProcPos:=CurEntryStart;
if proctypeoption in [potype_unitfinalize] then
FFinalProcPos:=CurEntryStart;
if (po_has_mangledname in procoptions) then begin
ReadEntryShortstring{$IFDEF VerbosePPUParser}(' Mangled name : '){$ENDIF};
end;
ReadEntryWord{$IFDEF VerbosePPUParser}(' Number : '){$ENDIF};
ReadEntryByte{$IFDEF VerbosePPUParser}(' Level : '){$ENDIF};
{$IFDEF VerbosePPUParser}
dbgout(' Class : ');
{$ENDIF}
ReadDereference;
{$IFDEF VerbosePPUParser}
dbgout(' Procsym : ');
{$ENDIF}
ReadDereference;
{$IFDEF VerbosePPUParser}
dbgout(' File Pos : ');
{$ENDIF}
readposinfo;
{$IFDEF VerbosePPUParser}
dbgout(' SymOptions : ');
{$ENDIF}
ReadSymOptions;
if tsystemcpu(FHeader.cpu)=cpu_powerpc then begin
{ library symbol for AmigaOS/MorphOS }
{$IFDEF VerbosePPUParser} dbgout(' Library symbol : '); {$ENDIF}
ReadDereference;
end;
if (po_has_importdll in procoptions) then
ReadEntryShortstring{$IFDEF VerbosePPUParser}(' Import DLL : '){$ENDIF};
if (po_has_importname in procoptions) then
ReadEntryShortstring{$IFDEF VerbosePPUParser}(' Import Name : '){$ENDIF};
ReadEntryWord{$IFDEF VerbosePPUParser}(' Import Nr : '){$ENDIF};
if (po_msgint in procoptions) then
ReadEntryLongint{$IFDEF VerbosePPUParser}(' MsgInt : '){$ENDIF};
if (po_msgstr in procoptions) then
ReadEntryShortstring{$IFDEF VerbosePPUParser}(' MsgStr : '){$ENDIF};
if (po_has_inlininginfo in procoptions) then begin
{$IFDEF VerbosePPUParser} dbgout(' FuncretSym : '); {$ENDIF}
ReadDereference;
ReadEntrySmallSet(procinfooptions);
{$IFDEF VerbosePPUParser} debugln([' ProcInfoOptions : ',dword(procinfooptions)]);{$ENDIF}
end;
// parast
ReadDefinitions;
ReadSymbols;
// localst
if (po_has_inlininginfo in procoptions) then
begin
ReadDefinitions;
ReadSymbols;
end;
if (po_has_inlininginfo in procoptions) then
readnodetree;
end;
ibenddefs:
break;
else
{$IFDEF VerbosePPUParser} DebugLn(['TPPU.ReadDefinitions Skipping unsupported: ',EntryNr]); {$ENDIF}
end;
{$IFDEF VerbosePPUParser}
if not EndOfEntry then
DebugLn(['TPPU.ReadDefinitions: Warning: Entry has more information stored']);
{$ENDIF}
until false;
end;
procedure TPPU.ReadSymbols;
type
pguid = ^tguid;
tguid = packed record
D1: LongWord;
D2: Word;
D3: Word;
D4: array[0..7] of Byte;
end;
absolutetyp = (
tovar,
toasm,
toaddr
);
tconsttyp = (
constnone,
constord,
conststring,
constreal,
constset,
constpointer,
constnil,
constresourcestring,
constwstring,
constguid
);
var
EntryNr: Byte;
begin
if ReadEntry<>ibstartsyms then
Error('missing ibstartsyms');
ReadEntryLongint{$IFDEF VerbosePPUParser}('Symtable datasize : '){$ENDIF};
if FEntryPos<FEntry.size then
ReadEntryLongint{$IFDEF VerbosePPUParser}('Symtable alignment: '){$ENDIF};
repeat
EntryNr:=ReadEntry;
case EntryNr of
ibendsyms:
break;
else
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadSymbols Skipping unsupported PPU Entry in Symbols: ',EntryNr]);
{$ENDIF}
end;
{$IFDEF VerbosePPUParser}
if not EndOfEntry then
DebugLn(['TPPU.ReadSymbols Entry has more information stored: ',EntryNr]);
{$ENDIF}
until false;
end;
procedure TPPU.ReadNodeTree;
begin
if ReadEntry<>ibnodetree then
Error('TPPU.ReadNodeTree missing ibnodetree');
FEntryPos:=FEntry.size;
end;
procedure TPPU.ReadCommonDefinition;
var
defoptions: tdefoptions;
defstates: tdefstates;
{$IFDEF VerbosePPUParser}
defopt: tdefoption;
defstate: tdefstate;
TokenBuf: Pointer;
TokenBufSize: LongInt;
i: Integer;
{$ENDIF}
begin
ReadEntryLongint{$IFDEF VerbosePPUParser}('DefinitionID='){$ENDIF};
ReadDereference;
ReadEntrySmallSet(defoptions);
{$IFDEF VerbosePPUParser}
if defoptions<>[] then begin
dbgout(' DefOptions:');
for defopt:=low(tdefoption) to high(tdefoption) do
if defopt in defoptions then
dbgout(' ',defoptionNames[defopt]);
debugln;
end;
{$ENDIF}
ReadEntrySmallSet(defstates);
{$IFDEF VerbosePPUParser}
if defstates<>[] then begin
dbgout(' DefStates:');
for defstate:=low(tdefstate) to high(tdefstate) do
if defstate in defstates then
dbgout(' ',defstateNames[defstate]);
debugln;
end;
{$ENDIF}
if df_generic in defoptions then begin
{$IFDEF VerbosePPUParser}TokenBufSize:={$ENDIF}ReadEntryLongint;
{$IFDEF VerbosePPUParser}
TokenBuf:=allocmem(TokenBufSize);
try
System.Move(Pointer(FEntryBuf+FEntryPos)^,TokenBuf^,TokenBufSize);
inc(FEntryPos,TokenBufSize);
i:=0;
while i<TokenBufSize do begin
// The tokens depends on compiler version
// ToDo: write tokens
inc(i);
end;
finally
FreeMem(TokenBuf);
end;
{$ENDIF}
end;
if df_specialization in defoptions then
begin
ReadDereference;
end;
end;
procedure TPPU.ReadAbstractProcDef(out proccalloption: tproccalloption;
out procoptions: tprocoptions; out proctypeoption: tproctypeoption);
var
i : longint;
{$IFDEF VerbosePPUParser}
po: tprocoption;
{$ENDIF}
begin
{$IFDEF VerbosePPUParser}
dbgout('Return type: ');
{$ENDIF}
ReadDereference;
ReadEntryByte{$IFDEF VerbosePPUParser}('FPU='){$ENDIF};
proctypeoption:=tproctypeoption(ReadEntryByte);
{$IFDEF VerbosePPUParser}
debugln('Typeoptions: ',proctypeoptionNames[proctypeoption]);
{$ENDIF}
proccalloption:=tproccalloption(ReadEntryByte);
{$IFDEF VerbosePPUParser}
debugln('CallOption : ',proccalloptionNames[proccalloption]);
{$ENDIF}
ReadEntryNormalSet(procoptions);
{$IFDEF VerbosePPUParser}
if procoptions<>[] then begin
dbgout('Options: ');
for po:=low(tprocoption) to high(tprocoption) do
if po in procoptions then
dbgout(' ',procoptionNames[po]);
debugln;
end;
{$ENDIF}
if (po_explicitparaloc in procoptions) then
begin
i:=ReadEntryByte;
inc(FEntryPos,i);
end;
end;
procedure TPPU.ReadSymOptions;
var
symoptions : tsymoptions;
{$IFDEF VerbosePPUParser}
s: tsymoption;
{$ENDIF}
begin
ReadEntrySmallSet(symoptions);
{$IFDEF VerbosePPUParser}
if symoptions<>[] then begin
for s:=Low(tsymoption) to high(tsymoption) do
if s in SymOptions then
dbgout(' ',symoptionNames[s]);
end;
debugln;
{$ENDIF}
end;
procedure TPPU.ReadDereference;
type
tdereftype = (
deref_nil,
deref_unit,
deref_symid,
deref_defid
);
var
DerefPos: LongInt;
pdata: PByte;
n: Byte;
i: Integer;
b: tdereftype;
{$IFDEF VerbosePPUParser}
idx: integer;
{$ENDIF}
begin
DerefPos:=ReadEntryLongint;
if DerefPos>=FDerefDataSize then
Error('Invalid Deref, DerefPos>=FDerefDataSize');
{$IFDEF VerbosePPUParser}
dbgout('(',IntToStr(DerefPos),')');
{$ENDIF}
pdata:=@FDerefData[DerefPos];
n:=pdata^;
if n<1 then
Error('Invalid Deref, n<1');
i:=1;
while i<=n do begin
b:=tdereftype(pdata[i]);
inc(i);
case b of
deref_nil :
begin
{$IFDEF VerbosePPUParser}
dbgout(' Nil');
{$ENDIF}
end;
deref_symid :
begin
{$IFDEF VerbosePPUParser}
idx:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3];
dbgout(' SymId ',IntToStr(idx));
{$ENDIF}
inc(i,4);
end;
deref_defid :
begin
{$IFDEF VerbosePPUParser}
idx:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3];
dbgout(' DefId ',IntToStr(idx));
{$ENDIF}
inc(i,4);
end;
deref_unit :
begin
{$IFDEF VerbosePPUParser}
idx:=pdata[i] shl 8 or pdata[i+1];
dbgout(' Unit ',IntToStr(idx));
{$ENDIF}
inc(i,2);
end;
else
begin
Error('unsupported dereftyp: '+IntToStr(ord(b)));
break;
end;
end;
end;
{$IFDEF VerbosePPUParser}
debugln;
{$ENDIF}
end;
procedure TPPU.ReadPosInfo;
var
info : byte;
fileindex,line,column : longint;
begin
{
info byte layout in bits:
0-1 - amount of bytes for fileindex
2-3 - amount of bytes for line
4-5 - amount of bytes for column
}
info:=ReadEntryByte;
case (info and $03) of
0 : fileindex:=ReadEntryByte;
1 : fileindex:=ReadEntryWord;
2 : fileindex:=(ReadEntryByte shl 16) or ReadEntryWord;
3 : fileindex:=ReadEntryLongint;
end;
case ((info shr 2) and $03) of
0 : line:=ReadEntryByte;
1 : line:=ReadEntryWord;
2 : line:=(ReadEntryByte shl 16) or ReadEntryWord;
3 : line:=ReadEntryLongint;
end;
case ((info shr 4) and $03) of
0 : column:=ReadEntryByte;
1 : column:=ReadEntryWord;
2 : column:=(ReadEntryByte shl 16) or ReadEntryWord;
3 : column:=ReadEntryLongint;
end;
if (fileindex<0) and (line<0) and (column<0) then ;
{$IFDEF VerbosePPUParser}
debugln(dbgs(fileindex),' (',dbgs(line),',',dbgs(column),')');
{$ENDIF}
end;
function TPPU.ReadEntry: byte;
begin
FEntryPos:=0;
FEntryStart:=FDataPos;
ReadData(FEntry,SizeOf(FEntry));
if fChangeEndian then
FEntry.size:=SwapEndian(FEntry.size);
//DebugLn(['TPPU.ReadEntry ',FEntry.Nr,' ',FDataPos]);
if not (FEntry.id in [mainentryid,subentryid]) then
Error('Invalid entry id '+IntToStr(FEntry.id));
Result:=FEntry.nr;
if FEntryBufSize<FEntry.size then begin
FEntryBufSize:=FEntryBufSize*2;
if FEntryBufSize<FEntry.size then
FEntryBufSize:=FEntry.size;
ReAllocMem(FEntryBuf,FEntryBufSize);
end;
if FEntry.size>0 then
ReadData(FEntryBuf^,FEntry.size);
end;
function TPPU.EndOfEntry: boolean;
begin
Result:=FEntryPos>=FEntry.Size;
end;
procedure TPPU.SkipUntilEntry(EntryNr: byte);
var
b: Byte;
begin
repeat
b:=ReadEntry;
until (b=ibend) or ((b=EntryNr) and (FEntry.id=mainentryid));
if b<>EntryNr then
Error('TPPU.SkipUntilEntry not found: '+IntToStr(EntryNr));
end;
procedure TPPU.ReadDataFromStream(s: TStream);
var
Entry: PPPUEntry;
procedure Grow(Add: integer);
const InitialSize = 65536;
var
NewSize: Integer;
begin
NewSize:=FDataPos+Add;
if NewSize<=FDataSize then exit;
if FDataSize<InitialSize then
FDataSize:=InitialSize
else
FDataSize:=FDataSize*2;
if FDataSize<NewSize then
FDataSize:=NewSize;
ReAllocMem(FData,FDataSize);
end;
function Read(Count: integer): Pointer;
begin
//DebugLn(['Read Count=',Count,' Pos=',FDataPos]);
// read and copy some more data to FData
Grow(Count);
Result:=Pointer(FData+FDataPos);
s.Read(Result^,Count);
inc(FDataPos,Count);
end;
function ReadEntryBlock: byte;
begin
Entry:=PPPUEntry(Read(SizeOf(FEntry)));
if not (Entry^.id in [mainentryid,subentryid]) then
Error('Invalid entry id '+IntToStr(Entry^.id));
Result:=Entry^.nr;
Read(Entry^.Size);
end;
procedure ReadUntilEntry(EntryNr: byte);
var
b: Byte;
begin
repeat
b:=ReadEntryBlock;
until (b=ibend) or ((b=EntryNr) and (Entry^.id=mainentryid));
end;
var
p: Pointer;
begin
Entry:=nil;
// read header
p:=Read(SizeOf(TPPUHeader));
System.Move(p^,FHeader,SizeOf(TPPUHeader));
if String(FHeader.id)<>PPU_ID then
Error('This is not a PPU. Wrong ID.');
// read version
FVersion:=StrToIntDef(String(FHeader.ver),0);
if FVersion<16 then
Error('Old PPU versions (<16) are not supported.');
// read rest of header
if fChangeEndian then begin
fHeader.compiler := swapendian(fHeader.compiler);
fHeader.cpu := swapendian(fHeader.cpu);
fHeader.target := swapendian(fHeader.target);
fHeader.flags := swapendian(fHeader.flags);
fHeader.size := swapendian(fHeader.size);
fHeader.checksum := swapendian(fHeader.checksum);
fHeader.interface_checksum := swapendian(fHeader.interface_checksum);
fHeader.deflistsize := swapendian(fHeader.deflistsize);
fHeader.symlistsize := swapendian(fHeader.symlistsize);
end;
fChangeEndian:=((FHeader.flags and uf_big_endian) = uf_big_endian)<>PPUIsEndianBig;
// read entries
ReadUntilEntry(ibendinterface);
ReadUntilEntry(ibenddefs);
ReadUntilEntry(ibendsyms);
if ReadEntryBlock<>ibexportedmacros then
Error('missing exported macros');
if boolean(PByte(PByte(Entry)+SizeOf(TPPUEntry))^) then begin
ReadUntilEntry(ibenddefs);
ReadUntilEntry(ibendsyms);
end;
ReadUntilEntry(ibendimplementation);
if (FHeader.flags and uf_local_symtable)<>0 then begin
ReadUntilEntry(ibenddefs);
ReadUntilEntry(ibendsyms);
end;
// shrink FData
FDataSize:=FDataPos;
ReAllocMem(FData,FDataSize);
FDataPos:=0;
end;
procedure TPPU.ReadData(var Buf; Count: longint);
begin
//DebugLn(['TPPU.ReadData Count=',Count,' Pos=',FDataPos]);
if FDataPos+Count>FDataSize then
Error('TPPU.ReadData: out of data');
System.Move(Pointer(FData+FDataPos)^,Buf,Count);
inc(FDataPos,Count);
end;
function TPPU.ReadEntryByte: byte;
begin
if FEntryPos>=FEntry.size then
Error('TPPU.ReadEntryByte: out of bytes');
Result:=PByte(FEntryBuf+FEntryPos)^;
inc(FEntryPos);
end;
function TPPU.ReadEntryByte(const Msg: string): byte;
begin
Result:=ReadEntryByte();
debugln([Msg,Result]);
end;
function TPPU.ReadEntryShortstring: shortstring;
var
l: byte;
s: shortstring;
begin
l:=ReadEntryByte;
s[0]:=chr(l);
if FEntryPos+l>FEntry.size then
Error('TPPU.ReadEntryShortstring: out of bytes ');
System.Move(Pointer(FEntryBuf+FEntryPos)^,s[1],l);
Result:=s;
inc(FEntryPos,l);
end;
function TPPU.ReadEntryShortstring(const Msg: string): shortstring;
begin
Result:=ReadEntryShortstring();
debugln([Msg,Result]);
end;
function TPPU.ReadEntryLongint: longint;
begin
if FEntryPos+4>FEntry.size then
Error('TPPU.ReadEntryLongint: out of bytes');
Result:=PLongint(FEntryBuf+FEntryPos)^;
inc(FEntryPos,4);
end;
function TPPU.ReadEntryLongint(const Msg: string): longint;
begin
Result:=ReadEntryLongint();
debugln([Msg,Result]);
end;
function TPPU.ReadEntryWord: word;
begin
if FEntryPos+2>FEntry.size then
Error('TPPU.ReadEntryLongint: out of bytes');
Result:=PWord(FEntryBuf+FEntryPos)^;
inc(FEntryPos,2);
end;
function TPPU.ReadEntryWord(const Msg: string): word;
begin
Result:=ReadEntryWord();
debugln([Msg,Result]);
end;
procedure TPPU.ReadEntrySmallSet(var s);
var
i: longint;
begin
if FEntryPos+4>FEntry.size then
Error('TPPU.ReadEntryLongint: out of bytes');
System.Move(PByte(FEntryBuf+FEntryPos)^,s,4);
inc(FEntryPos,4);
if fChangeEndian then
for i:=0 to 3 do
Pbyte(@s)[i]:=reverse_byte(Pbyte(@s)[i]);
end;
procedure TPPU.ReadEntryNormalSet(var s);
var
i: longint;
begin
if FEntryPos+32>FEntry.size then
Error('TPPU.ReadEntryLongint: out of bytes');
System.Move(PByte(FEntryBuf+FEntryPos)^,s,32);
inc(FEntryPos,32);
if fChangeEndian then
for i:=0 to 31 do
Pbyte(@s)[i]:=reverse_byte(Pbyte(@s)[i]);
end;
procedure TPPU.ReadUsedUnits;
{$IFDEF VerbosePPUParser}
var
AUnitName: ShortString;
CRC: LongInt;
IntfCRC: LongInt;
{$ENDIF}
begin
while not EndOfEntry do begin
{$IFDEF VerbosePPUParser}AUnitName:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}CRC:={$ENDIF}ReadEntryLongint;
{$IFDEF VerbosePPUParser}IntfCRC:={$ENDIF}ReadEntryLongint;
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadUsedUnits Unit=',AUnitName,' CRC=',HexStr(cardinal(CRC),8),' IntfCRC=',HexStr(cardinal(IntfCRC),8)]);
{$ENDIF}
end;
end;
procedure TPPU.ReadLinkContainer(Nr: byte);
{$IFDEF VerbosePPUParser}
const
{ link options }
link_none = $0;
link_always = $1;
link_static = $2;
link_smart = $4;
link_shared = $8;
var
Desc: String;
var
Filename: ShortString;
Flags: LongInt;
{$ENDIF}
begin
while not EndOfEntry do begin
{$IFDEF VerbosePPUParser}Filename:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}Flags:={$ENDIF}ReadEntryLongint;
{$IFDEF VerbosePPUParser}
case Nr of
iblinkunitofiles:
Desc:='Link unit object file: ';
iblinkunitstaticlibs :
Desc:='Link unit static lib: ';
iblinkunitsharedlibs :
Desc:='Link unit shared lib: ';
iblinkotherofiles :
Desc:='Link other object file: ';
iblinkotherstaticlibs :
Desc:='Link other static lib: ';
iblinkothersharedlibs :
Desc:='Link other shared lib: ';
end;
Desc:=Desc+Filename;
if (Flags and link_always)<>0 then
Desc:=Desc+' always';
if (Flags and link_static)<>0 then
Desc:=Desc+' static';
if (Flags and link_smart)<>0 then
Desc:=Desc+' smart';
if (Flags and link_shared)<>0 then
Desc:=Desc+' shared';
DebugLn(['TPPU.ReadLinkContainer ',Desc]);
{$ENDIF}
end;
end;
procedure TPPU.ReadImportSymbols;
var
SymbolCount: LongInt;
i: Integer;
{$IFDEF VerbosePPUParser}
LibName: ShortString;
SymbolName: ShortString;
SymbolOrdNr: LongInt;
SymbolIsVar: Boolean;
{$ENDIF}
begin
while not EndOfEntry do begin
{$IFDEF VerbosePPUParser}LibName:={$ENDIF}ReadEntryShortstring;
SymbolCount:=ReadEntryLongint;
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadImportSymbols External Library: ',LibName,' (',SymbolCount,' imports)']);
{$ENDIF}
for i:=0 to SymbolCount-1 do
begin
{$IFDEF VerbosePPUParser}SymbolName:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}SymbolOrdNr:={$ENDIF}ReadEntryLongint;
{$IFDEF VerbosePPUParser}SymbolIsVar:=ReadEntryByte<>0{$ELSE}ReadEntryByte{$ENDIF};
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadImportSymbols ',SymbolName,' (OrdNr: ',SymbolOrdNr,' IsVar: ',SymbolIsVar,')']);
{$ENDIF}
end;
end;
end;
procedure TPPU.ReadDerefData;
begin
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadDerefData Deref Data length: ',FEntry.size-FEntryPos]);
{$ENDIF}
FDerefDataSize:=FEntry.size-FEntryPos;
if FDerefDataSize>0 then begin
FDerefData:=AllocMem(FDerefDataSize);
System.Move(PByte(FEntryBuf+FEntryPos)^,FDerefData^,FDerefDataSize);
FEntryPos:=FEntry.size;
end;
end;
procedure TPPU.ReadDerefMap;
var
Count: LongInt;
i: Integer;
{$IFDEF VerbosePPUParser}
MapName: ShortString;
{$ENDIF}
begin
Count:=ReadEntryLongint;
for i:=0 to Count-1 do begin
{$IFDEF VerbosePPUParser}MapName:={$ENDIF}ReadEntryShortstring;
{$IFDEF VerbosePPUParser}
DebugLn(['TPPU.ReadDerefMap ',i,' ',MapName]);
{$ENDIF}
end;
end;
procedure TPPU.Skip(Count: integer);
begin
if FDataPos+Count>FDataSize then
Error('TPPU.Skip: out of data');
inc(FDataPos,Count);
end;
procedure TPPU.Error(const Msg: string);
begin
raise EPPUParserError.Create(Msg);
end;
procedure TPPU.GetUsesSection(StartPos: integer; var List: TStrings);
var
AUnitName: String;
begin
if StartPos<=0 then exit;
SetDataPos(StartPos);
if ReadEntry<>ibloadunit then exit;
while not EndOfEntry do begin
AUnitName:=ReadEntryShortstring;
if List=nil then
List:=TStringList.Create;
if List.IndexOf(AUnitName)<0 then
List.Add(AUnitName);
ReadEntryLongint; // CRC
ReadEntryLongint; // IntfCRC
end;
end;
procedure TPPU.SetDataPos(NewPos: integer);
begin
FillByte(FEntry,SizeOf(FEntry),0);
FEntryPos:=0;
FDataPos:=NewPos;
end;
function TPPU.GetProcMangledName(ProcDefPos: integer): string;
var
calloption: tproccalloption;
procoptions: tprocoptions;
proctypeoption: tproctypeoption;
begin
Result:='';
if ProcDefPos<=0 then exit;
SetDataPos(ProcDefPos);
if ReadEntry<>ibprocdef then exit;
ReadCommonDefinition;
ReadAbstractProcDef(calloption,procoptions,proctypeoption);
if (po_has_mangledname in procoptions) then
Result:=ReadEntryShortstring;
end;
constructor TPPU.Create;
begin
end;
destructor TPPU.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TPPU.Clear;
begin
FillByte(FHeader,SizeOf(FHeader),0);
FillByte(FEntry,SizeOf(FEntry),0);
FEntryPos:=0;
ReAllocMem(FEntryBuf,0);
FEntryBufSize:=0;
ReAllocMem(FDerefData,0);
FDerefDataSize:=0;
ReAllocMem(FData,0);
FDataSize:=0;
FDataPos:=0;
FMainUsesSectionPos:=0;
FImplementationUsesSectionPos:=0;
FInitProcPos:=0;
FFinalProcPos:=0;
end;
procedure TPPU.LoadFromStream(s: TStream; const Parts: TPPUParts);
begin
Clear;
ReadDataFromStream(s);
ReadPPU(Parts);
end;
procedure TPPU.LoadFromFile(const Filename: string; const Parts: TPPUParts);
var
ms: TMemoryStream;
fs: TFileStream;
begin
fs:=TFileStream.Create(UTF8ToSys(Filename),fmOpenRead or fmShareDenyWrite);
ms:=TMemoryStream.Create;
try
ms.Size:=fs.Size;
ms.CopyFrom(fs,fs.Size);
ms.Position:=0;
LoadFromStream(ms,Parts);
finally
ms.Free;
fs.Free;
end;
end;
procedure TPPU.Dump(const Prefix: string);
begin
DebugLn([Prefix+'TPPU.Dump ']);
DumpHeader(Prefix+' ');
end;
procedure TPPU.DumpHeader(const Prefix: string);
begin
DebugLn([Prefix,'Header']);
DebugLn([Prefix,' ID=',String(FHeader.ID)]);
DebugLn([Prefix,' Ver=',StrToIntDef(String(FHeader.ver),0)]);
DebugLn([Prefix,' Compiler=',FHeader.compiler shr 14,'.',
(FHeader.compiler shr 7) and $7f,'.',
FHeader.compiler and $7f]);
DebugLn([Prefix,' Target CPU=',PPUCpuToStr(FHeader.cpu)]);
DebugLn([Prefix,' Target OS=',PPUTargetToStr(FHeader.target)]);
DebugLn([Prefix,' Unit Flags=',PPUFlagsToStr(FHeader.flags)]);
DebugLn([Prefix,' Filesize (w/o header)=',FHeader.size]);
DebugLn([Prefix,' Checksum=',HexStr(cardinal(FHeader.checksum),8)]);
DebugLn([Prefix,' Interface CheckSum=',HexStr(cardinal(FHeader.interface_checksum),8)]);
DebugLn([Prefix,' Number of Definitions=',FHeader.deflistsize]);
DebugLn([Prefix,' Number of Symbols=',FHeader.symlistsize]);
end;
procedure TPPU.GetMainUsesSectionNames(var List: TStrings);
begin
GetUsesSection(FMainUsesSectionPos,List);
end;
procedure TPPU.GetImplementationUsesSectionNames(var List: TStrings);
begin
GetUsesSection(FImplementationUsesSectionPos,List);
end;
function TPPU.GetInitProcName: string;
begin
Result:=GetProcMangledName(FInitProcPos);
end;
function TPPU.GetFinalProcName: string;
begin
Result:=GetProcMangledName(FFinalProcPos);
end;
end.
Reference in New Issue View Git Blame Copy Permalink