mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 15:32:00 +01:00
2718 lines
79 KiB
ObjectPascal
2718 lines
79 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* 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
|
|
|
|
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, contnrs, FileProcs, LazFileUtils, lazutf8classes;
|
|
|
|
const
|
|
PPUIsEndianBig = {$IFDEF ENDIAN_BIG}True{$ELSE}False{$ENDIF};
|
|
|
|
// from ppu.pas
|
|
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;
|
|
ibunicodestringdef = 59; // svn rev 9382
|
|
{implementation/ObjData}
|
|
ibnodetree = 80;
|
|
ibasmsymbols = 81;
|
|
ibresources = 82; // svn rev 7515 ppu version 80
|
|
ibcreatedobjtypes = 83; // svn rev 12341 ppu version 95
|
|
ibwpofile = 84; // svn rev 12341 ppu version 95
|
|
ibmoduleoptions = 85; // svn rev 14767 ppu version 114
|
|
|
|
ibmainname = 90; // svn rev 10406
|
|
ibsymtableoptions = 91; // svn rev 17328 ppu version 128
|
|
ibrecsymtableoptions = 91; // svn rev 18114
|
|
{ target-specific things }
|
|
iblinkotherframeworks = 100; // svn rev 8344
|
|
ibjvmnamespace = 101; // svn rec 21069
|
|
|
|
{ unit flags }
|
|
uf_init = $000001; { unit has initialization section }
|
|
uf_finalize = $000002; { unit has finalization section }
|
|
uf_big_endian = $000004;
|
|
//uf_has_browser = $000010;
|
|
uf_in_library = $000020; { is the file in another file than <ppufile>.* ? }
|
|
uf_smart_linked = $000040; { the ppu can be smartlinked }
|
|
uf_static_linked = $000080; { the ppu can be linked static }
|
|
uf_shared_linked = $000100; { the ppu can be linked shared }
|
|
//uf_local_browser = $000200;
|
|
uf_no_link = $000400; { unit has no .o generated, but can still have external linking! }
|
|
uf_has_resourcestrings = $000800; { unit has resource string section }
|
|
uf_little_endian = $001000;
|
|
uf_release = $002000; { unit was compiled with -Ur option }
|
|
uf_threadvars = $004000; { unit has threadvars }
|
|
uf_fpu_emulation = $008000; { this unit was compiled with fpu emulation on }
|
|
uf_has_stabs_debuginfo = $010000; { this unit has stabs debuginfo generated }
|
|
uf_local_symtable = $020000; { this unit has a local symtable stored }
|
|
uf_uses_variants = $040000; { this unit uses variants }
|
|
uf_has_resourcefiles = $080000; { this unit has external resources (using $R directive)}
|
|
uf_has_exports = $100000; { this module or a used unit has exports }
|
|
uf_has_dwarf_debuginfo = $200000; { this unit has dwarf debuginfo generated }
|
|
uf_wideinits = $400000; { this unit has winlike widestring typed constants }
|
|
uf_classinits = $800000; { this unit has class constructors/destructors }
|
|
uf_resstrinits = $1000000; { svn rev 18968: this unit has string consts referencing resourcestrings }
|
|
uf_i8086_far_code = $2000000; { svn rev 25365: this unit uses an i8086 memory model with far code (i.e. medium, large or huge) }
|
|
uf_i8086_far_data = $4000000; { svn rev 25365: this unit uses an i8086 memory model with far data (i.e. compact or large) }
|
|
uf_i8086_huge_data = $8000000; { svn rev 25365: this unit uses an i8086 memory model with huge data (i.e. huge) }
|
|
uf_i8086_cs_equals_ds = $10000000; { svn rev 27516: this unit uses an i8086 memory model with CS=DS (i.e. tiny) }
|
|
|
|
// from systems.inc
|
|
type
|
|
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_mipseb, { 9 }
|
|
cpu_arm, { 10 }
|
|
cpu_powerpc64, { 11 }
|
|
cpu_avr, { 12 }
|
|
cpu_mipsel, { 13 }
|
|
cpu_jvm, { 14 }
|
|
cpu_i8086, { 15 }
|
|
cpu_aarch64 { 16 }
|
|
);
|
|
|
|
const
|
|
PPU_CPUNames : array[tsystemcpu] of string[9]=
|
|
('none',
|
|
'i386',
|
|
'm68k',
|
|
'alpha',
|
|
'powerpc',
|
|
'sparc',
|
|
'vis',
|
|
'ia64',
|
|
'x86_64',
|
|
'mips',
|
|
'arm',
|
|
'powerpc64',
|
|
'avr',
|
|
'mipsel',
|
|
'jvm',
|
|
'i8086',
|
|
'aarch64'
|
|
);
|
|
|
|
// from ppu.pas
|
|
{ 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'}
|
|
);
|
|
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'}
|
|
);
|
|
|
|
type
|
|
// from globtype.pas
|
|
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;
|
|
|
|
// from symconst.pas
|
|
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,
|
|
potype_class_constructor, { class constructor }
|
|
potype_class_destructor { class destructor }
|
|
);
|
|
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_finalmethod, { Procedure is a final 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, // deleted in PPUVersion 167
|
|
{ The different kind of syscalls on MorphOS }
|
|
po_syscall_legacy,
|
|
po_syscall_sysv,
|
|
po_syscall_basesysv,
|
|
po_syscall_sysvbase,
|
|
po_syscall_r12base,
|
|
{ Used to record the fact that a symbol is asociated to this syscall }
|
|
po_syscall_has_libsym,
|
|
{ Procedure can be inlined }
|
|
po_inline,
|
|
{ Procedure is used for internal compiler calls }
|
|
po_compilerproc,
|
|
{ importing }
|
|
po_has_importdll,
|
|
po_has_importname,
|
|
po_kylixlocal,
|
|
po_dispid,
|
|
{ weakly linked (i.e., may or may not exist at run time) }
|
|
po_weakexternal,
|
|
{ Objective-C method }
|
|
po_objc,
|
|
{ enumerator support }
|
|
po_enumerator_movenext,
|
|
{ optional Objective-C protocol method }
|
|
po_optional,
|
|
{ nested procedure that uses Delphi-style calling convention for passing
|
|
the frame pointer (pushed on the stack, always the last parameter,
|
|
removed by the caller). Required for nested procvar compatibility,
|
|
because such procvars can hold both regular and nested procedures
|
|
(when calling a regular procedure using the above convention, it will
|
|
simply not see the frame pointer parameter, and since the caller cleans
|
|
up the stack will also remain balanced) }
|
|
po_delphi_nested_cc,
|
|
{ allows the routine's RawByteString var/out parameters to accept parameters
|
|
that do not match exactly (without typeconversion) }
|
|
po_rtlproc,
|
|
{ Non-virtual method of a Java class that has been transformed into a
|
|
"virtual; final;" method for JVM-implementation reasons }
|
|
po_java_nonvirtual,
|
|
{ automatically inherited routine from parent class, ignore for resolving
|
|
overloads (on the JVM target, constructors are not automatically
|
|
inherited, so we explicitly have to add the constructors of the parent
|
|
class to the child class; this influences the overload resolution logic
|
|
though, so ignore them there) }
|
|
po_ignore_for_overload_resolution,
|
|
{ the visibility of of this procdef was raised automatically by the
|
|
compiler, e.g. because it was designated as a getter/setter for a property
|
|
with a higher visibility on the JVM target }
|
|
po_auto_raised_visibility,
|
|
{ procedure is far (x86 only) }
|
|
po_far,
|
|
{ the procedure never returns, this information is usefull for dfa }
|
|
po_noreturn
|
|
);
|
|
tprocoptions = set of tprocoption;
|
|
|
|
{ options that should not trigger the recompilation of a unit if they change
|
|
between the interface and the implementation }
|
|
timplprocoption = (
|
|
{ the routine contains no code }
|
|
pio_empty,
|
|
{ the inline body of this routine is available }
|
|
pio_has_inlininginfo
|
|
);
|
|
timplprocoptions = set of timplprocoption;
|
|
|
|
const
|
|
proccalloptionNames : array[tproccalloption] of string[14]=('',
|
|
'CDecl',
|
|
'CPPDecl',
|
|
'Far16',
|
|
'OldFPCCall',
|
|
'InternProc',
|
|
'SysCall',
|
|
'Pascal',
|
|
'Register',
|
|
'SafeCall',
|
|
'StdCall',
|
|
'SoftFloat',
|
|
'MWPascal'
|
|
);
|
|
proctypeoptionNames : array[tproctypeoption] of string[20]=(
|
|
'none',
|
|
'ProgInit',
|
|
'UnitInit',
|
|
'UnitFinalize',
|
|
'Constructor',
|
|
'Destructor',
|
|
'Operator',
|
|
'Procedure',
|
|
'Function',
|
|
'Class Constructor',
|
|
'Class Destructor'
|
|
);
|
|
procoptionNames : array[tprocoption] of string[30]=(
|
|
'none',
|
|
'classmethod', { class method }
|
|
'virtualmethod', { Procedure is a virtual method }
|
|
'abstractmethod', { Procedure is an abstract method }
|
|
'finalmethod', { Procedure is a final 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',
|
|
'po_has_inlininginfo',
|
|
{ The different kind of syscalls on MorphOS }
|
|
'syscall_legacy',
|
|
'syscall_sysv',
|
|
'syscall_basesysv',
|
|
'syscall_sysvbase',
|
|
'syscall_r12base',
|
|
{ Used to record the fact that a symbol is asociated to this syscall }
|
|
'syscall_has_libsym',
|
|
{ Procedure can be inlined }
|
|
'inline',
|
|
{ Procedure is used for internal compiler calls }
|
|
'compilerproc',
|
|
{ importing }
|
|
'has_importdll',
|
|
'has_importname',
|
|
'kylixlocal',
|
|
'dispid',
|
|
{ weakly linked (i.e., may or may not exist at run time) }
|
|
'weakexternal',
|
|
{ Objective-C method }
|
|
'objc',
|
|
{ enumerator support }
|
|
'enumerator_movenext',
|
|
{ optional Objective-C protocol method }
|
|
'optional',
|
|
{ nested procedure that uses Delphi-style calling convention for passing
|
|
the frame pointer (pushed on the stack, always the last parameter,
|
|
removed by the caller). Required for nested procvar compatibility,
|
|
because such procvars can hold both regular and nested procedures
|
|
(when calling a regular procedure using the above convention, it will
|
|
simply not see the frame pointer parameter, and since the caller cleans
|
|
up the stack will also remain balanced) }
|
|
'delphi_nested_cc',
|
|
{ allows the routine's RawByteString var/out parameters to accept parameters
|
|
that do not match exactly (without typeconversion) }
|
|
'rtlproc',
|
|
{ Non-virtual method of a Java class that has been transformed into a
|
|
"virtual; final;" method for JVM-implementation reasons }
|
|
'java_nonvirtual',
|
|
{ automatically inherited routine from parent class, ignore for resolving
|
|
overloads (on the JVM target, constructors are not automatically
|
|
inherited, so we explicitly have to add the constructors of the parent
|
|
class to the child class; this influences the overload resolution logic
|
|
though, so ignore them there) }
|
|
'ignore_for_overload_resolution',
|
|
{ the visibility of of this procdef was raised automatically by the
|
|
compiler, e.g. because it was designated as a getter/setter for a property
|
|
with a higher visibility on the JVM target }
|
|
'auto_raised_visibility',
|
|
{ procedure is far (x86 only) }
|
|
'far',
|
|
{ the procedure never returns, this information is usefull for dfa }
|
|
'noreturn'
|
|
);
|
|
|
|
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,
|
|
df_genconstraint
|
|
);
|
|
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;
|
|
|
|
{ flags for generic type constraints }
|
|
tgenericconstraintflag=(gcf_none,
|
|
gcf_constructor, { specialization type needs to have a constructor }
|
|
gcf_class, { specialization type needs to be a class }
|
|
gcf_record { specialization type needs to be a record type }
|
|
);
|
|
tgenericconstraintflags=set of tgenericconstraintflag;
|
|
|
|
const
|
|
defoptionNames : array[tdefoption] of string=(
|
|
'?',
|
|
'Unique Type',
|
|
'Generic',
|
|
'Specialization',
|
|
'Generic Constraint'
|
|
);
|
|
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;
|
|
indirect_checksum: cardinal; // svn rev 14503
|
|
end;
|
|
|
|
TPPUEntry = packed record
|
|
size : longint; // number of bytes following directly behind the entry
|
|
id : byte;
|
|
nr : byte;
|
|
end;
|
|
PPPUEntry = ^TPPUEntry;
|
|
|
|
TPPU = class;
|
|
|
|
{ EPPUParserError }
|
|
|
|
EPPUParserError = class(Exception)
|
|
Sender: TPPU;
|
|
constructor Create(ASender: TPPU; const AMessage: string);
|
|
end;
|
|
|
|
TPPULinkedFile = class
|
|
public
|
|
ID: byte; // see iblinkunitofiles, iblink...
|
|
Filename: string;
|
|
Flags: Longint;
|
|
end;
|
|
|
|
{ TPPU }
|
|
|
|
TPPU = class
|
|
private
|
|
FSizeOfAInt: integer;
|
|
FSizeOfASizeInt: integer;
|
|
fChangeEndian: boolean;
|
|
FHeader: TPPUHeader;
|
|
FEntry: TPPUEntry;
|
|
FEntryStart: integer;
|
|
FEntryPos: integer;
|
|
FEntryBuf: Pointer;
|
|
FEntryBufSize: integer;
|
|
FOwner: TObject;
|
|
FVersion: integer;
|
|
FDerefData: PByte;
|
|
FDerefDataSize: integer;
|
|
FData: Pointer;
|
|
FDataPos: integer;
|
|
FDataSize: integer;
|
|
FInterfaceHeaderPos: integer; // start of the interface header entries
|
|
FImplementationHeaderPos: integer; // start of the implementation header entries
|
|
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 ReadEntryAnsistring: ansistring;
|
|
function ReadEntryAnsistring(const Msg: string): ansistring;
|
|
function ReadEntryLongint: longint;
|
|
function ReadEntryLongint(const Msg: string): longint;
|
|
function ReadEntryDWord: cardinal;
|
|
function ReadEntryDWord(const Msg: string): cardinal;
|
|
function ReadEntryWord: word;
|
|
function ReadEntryWord(const Msg: string): word;
|
|
function ReadEntryInt64: int64;
|
|
function ReadEntryInt64(const Msg: string): int64;
|
|
function ReadEntryQWord: QWord;
|
|
function ReadEntryQWord(const Msg: string): QWord;
|
|
function ReadEntryAInt: int64;
|
|
function ReadEntryAInt(const Msg: string): int64;
|
|
function ReadEntryASizeInt: int64;
|
|
function ReadEntryASizeInt(const Msg: string): int64;
|
|
procedure ReadEntrySmallSet(out s);
|
|
procedure ReadEntryNormalSet(out s);
|
|
procedure ReadUsedUnits;
|
|
procedure ReadModuleOptions;
|
|
procedure ReadLinkContainer(aContainerType: byte);
|
|
procedure ReadResources;
|
|
procedure ReadImportSymbols;
|
|
procedure ReadDerefData;
|
|
procedure ReadDerefMap;
|
|
procedure ReadDereference;
|
|
procedure ReadPosInfo;
|
|
procedure ReadSymTableOptions;
|
|
procedure ReadDefinitions;
|
|
procedure ReadProcImplOptions(out ImplProcOptions: timplprocoptions);
|
|
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(TheOwner: TObject);
|
|
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);
|
|
procedure GetLinkedFiles(var ListOfTPPULinkedFile: TObjectList);
|
|
function GetInitProcName: string;
|
|
function GetFinalProcName: string;
|
|
property Version: integer read FVersion;
|
|
property Owner: TObject read FOwner;
|
|
end;
|
|
|
|
function PPUTargetToStr(w: longint): string;
|
|
function PPUCpuToStr(w: longint): string;
|
|
function PPUFlagsToStr(flags: longint): string;
|
|
function PPUTimeToStr(t: longint): string;
|
|
|
|
function PPULinkContainerFlagToStr(Flags: longint): string;
|
|
|
|
function PPUEntryName(Entry: byte): string;
|
|
|
|
function ComparePPULinkedFiles(Item1, Item2: Pointer): integer;
|
|
|
|
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 =
|
|
(
|
|
system_none, { 0 }
|
|
obsolete_system_i386_GO32V1,{ 1 }
|
|
system_i386_GO32V2, { 2 }
|
|
system_i386_linux, { 3 }
|
|
system_i386_OS2, { 4 }
|
|
system_i386_Win32, { 5 }
|
|
system_i386_freebsd, { 6 }
|
|
system_m68k_Amiga, { 7 }
|
|
system_m68k_Atari, { 8 }
|
|
system_m68k_Mac, { 9 }
|
|
system_m68k_linux, { 10 }
|
|
system_m68k_PalmOS, { 11 }
|
|
system_alpha_linux, { 12 }
|
|
system_powerpc_linux, { 13 }
|
|
system_powerpc_macos, { 14 }
|
|
system_i386_solaris, { 15 }
|
|
system_i386_beos, { 16 }
|
|
system_i386_netbsd, { 17 }
|
|
system_m68k_netbsd, { 18 }
|
|
system_i386_Netware, { 19 }
|
|
system_i386_qnx, { 20 }
|
|
system_i386_wdosx, { 21 }
|
|
system_sparc_solaris, { 22 }
|
|
system_sparc_linux, { 23 }
|
|
system_i386_openbsd, { 24 }
|
|
system_m68k_openbsd, { 25 }
|
|
system_x86_64_linux, { 26 }
|
|
system_powerpc_darwin, { 27 }
|
|
system_i386_emx, { 28 }
|
|
system_powerpc_netbsd, { 29 }
|
|
system_powerpc_openbsd, { 30 }
|
|
system_arm_linux, { 31 }
|
|
system_i386_watcom, { 32 }
|
|
system_powerpc_MorphOS, { 33 }
|
|
system_x86_64_freebsd, { 34 }
|
|
system_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_powerpc64_linux, { 43 }
|
|
system_i386_darwin, { 44 }
|
|
system_arm_palmos, { 45 }
|
|
system_powerpc64_darwin, { 46 }
|
|
system_arm_nds, { 47 }
|
|
system_i386_embedded, { 48 }
|
|
system_m68k_embedded, { 49 }
|
|
system_alpha_embedded, { 50 }
|
|
system_powerpc_embedded, { 51 }
|
|
system_sparc_embedded, { 52 }
|
|
system_vm_embedded, { 53 }
|
|
system_iA64_embedded, { 54 }
|
|
system_x86_64_embedded, { 55 }
|
|
system_mips_embedded, { 56 }
|
|
system_arm_embedded, { 57 }
|
|
system_powerpc64_embedded, { 58 }
|
|
system_i386_symbian, { 59 }
|
|
system_arm_symbian, { 60 }
|
|
system_x86_64_darwin, { 61 }
|
|
system_avr_embedded, { 62 }
|
|
system_i386_haiku, { 63 }
|
|
system_arm_darwin, { 64 }
|
|
system_x86_64_solaris, { 65 }
|
|
system_mips_linux, { 66 }
|
|
system_mipsel_linux, { 67 }
|
|
system_i386_nativent, { 68 }
|
|
system_i386_iphonesim, { 69 }
|
|
system_powerpc_wii, { 70 }
|
|
system_x86_64_openbsd, { 71 }
|
|
system_x86_64_netbsd, { 72 }
|
|
system_powerpc_aix, { 73 }
|
|
system_powerpc64_aix, { 74 }
|
|
system_jvm_java32, { 75 }
|
|
system_jvm_android32, { 76 }
|
|
system_arm_android, { 77 }
|
|
system_i386_android, { 78 }
|
|
system_i8086_msdos, { 79 }
|
|
system_mipsel_android, { 80 }
|
|
system_mipseb_embedded, { 81 }
|
|
system_mipsel_embedded, { 82 }
|
|
system_i386_aros, { 83 }
|
|
system_x86_64_aros, { 84 }
|
|
system_x86_64_dragonfly, { 85 }
|
|
system_aarch64_darwin, { 85 }
|
|
system_x86_64_iphonesim { 86 }
|
|
);
|
|
const
|
|
// taken form ppudump.pp
|
|
Targets : array[ttarget] of string[18]=(
|
|
{ 0 } 'none',
|
|
{ 1 } 'GO32V1 (obsolete)',
|
|
{ 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 } 'Linux-powerpc64',
|
|
{ 44 } 'Darwin-i386',
|
|
{ 45 } 'PalmOS-arm',
|
|
{ 46 } 'MacOSX-powerpc64',
|
|
{ 47 } 'NDS-arm',
|
|
{ 48 } 'Embedded-i386',
|
|
{ 49 } 'Embedded-m68k',
|
|
{ 50 } 'Embedded-alpha',
|
|
{ 51 } 'Embedded-powerpc',
|
|
{ 52 } 'Embedded-sparc',
|
|
{ 53 } 'Embedded-vm',
|
|
{ 54 } 'Embedded-iA64',
|
|
{ 55 } 'Embedded-x64',
|
|
{ 56 } 'Embedded-mips',
|
|
{ 57 } 'Embedded-arm',
|
|
{ 58 } 'Embedded-powerpc64',
|
|
{ 59 } 'Symbian-i386',
|
|
{ 60 } 'Symbian-arm',
|
|
{ 61 } 'MacOSX-x64',
|
|
{ 62 } 'Embedded-avr',
|
|
{ 63 } 'Haiku-i386',
|
|
{ 64 } 'Darwin-ARM',
|
|
{ 65 } 'Solaris-x86-64',
|
|
{ 66 } 'Linux-MIPS',
|
|
{ 67 } 'Linux-MIPSel',
|
|
{ 68 } 'NativeNT-i386',
|
|
{ 69 } 'iPhoneSim-i386',
|
|
{ 70 } 'Wii-powerpc',
|
|
{ 71 } 'OpenBSD-x86-64',
|
|
{ 72 } 'NetBSD-x86-64',
|
|
{ 73 } 'AIX-powerpc',
|
|
{ 74 } 'AIX-powerpc64',
|
|
{ 75 } 'Java-JVM',
|
|
{ 76 } 'Android-JVM',
|
|
{ 77 } 'Android-arm',
|
|
{ 78 } 'Android-i386',
|
|
{ 79 } 'MSDOS-i8086',
|
|
{ 80 } 'Android-MIPSel',
|
|
{ 81 } 'Embedded-mipseb',
|
|
{ 82 } 'Embedded-mipsel',
|
|
{ 83 } 'AROS-i386',
|
|
{ 84 } 'AROS-x86-64',
|
|
{ 85 } 'DragonFly-x86-64',
|
|
{ 85 } 'Darwin-AArch64',
|
|
{ 86 } 'iPhoneSim-x86-64'
|
|
);
|
|
begin
|
|
if w<=ord(high(ttarget)) then
|
|
Result:=Targets[ttarget(w)]
|
|
else
|
|
Result:='<!! Unknown target value '+IntToStr(w)+'>';
|
|
end;
|
|
|
|
function PPUCpuToStr(w:longint):string;
|
|
begin
|
|
if w<=ord(high(tsystemcpu)) then
|
|
Result:=PPU_CPUNames[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 := FileDateToDateTimeDef(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;
|
|
|
|
function PPULinkContainerFlagToStr(Flags: longint): string;
|
|
const
|
|
{ link options }
|
|
//link_none = $0;
|
|
link_always = $1;
|
|
link_static = $2;
|
|
link_smart = $4;
|
|
link_shared = $8;
|
|
begin
|
|
Result:='';
|
|
if (Flags and link_always)<>0 then
|
|
Result:=Result+'always,';
|
|
if (Flags and link_static)<>0 then
|
|
Result:=Result+'static,';
|
|
if (Flags and link_smart)<>0 then
|
|
Result:=Result+'smart,';
|
|
if (Flags and link_shared)<>0 then
|
|
Result:=Result+'shared,';
|
|
if Result<>'' then Result:=copy(Result,1,length(Result)-1);
|
|
end;
|
|
|
|
function PPUEntryName(Entry: byte): string;
|
|
begin
|
|
case Entry of
|
|
iberror: Result:='iberror';
|
|
ibstartdefs: Result:='ibstartdefs';
|
|
ibenddefs: Result:='ibenddefs';
|
|
ibstartsyms: Result:='ibstartsyms';
|
|
ibendsyms: Result:='ibendsyms';
|
|
ibendinterface: Result:='ibendinterface';
|
|
ibendimplementation: Result:='ibendimplementation';
|
|
ibendbrowser: Result:='ibendbrowser';
|
|
ibend: Result:='ibend';
|
|
{general}
|
|
ibmodulename: Result:='ibmodulename';
|
|
ibsourcefiles: Result:='ibsourcefiles';
|
|
ibloadunit: Result:='ibloadunit';
|
|
ibinitunit: Result:='ibinitunit';
|
|
iblinkunitofiles: Result:='iblinkunitofiles';
|
|
iblinkunitstaticlibs: Result:='iblinkunitstaticlibs';
|
|
iblinkunitsharedlibs: Result:='iblinkunitsharedlibs';
|
|
iblinkotherofiles: Result:='iblinkotherofiles';
|
|
iblinkotherstaticlibs: Result:='iblinkotherstaticlibs';
|
|
iblinkothersharedlibs: Result:='iblinkothersharedlibs';
|
|
ibImportSymbols: Result:='ibImportSymbols';
|
|
ibsymref: Result:='ibsymref';
|
|
ibdefref: Result:='ibdefref';
|
|
ibendsymtablebrowser: Result:='ibendsymtablebrowser';
|
|
ibbeginsymtablebrowser: Result:='ibbeginsymtablebrowser';
|
|
ibusedmacros: Result:='ibusedmacros';
|
|
ibderefdata: Result:='ibderefdata';
|
|
ibexportedmacros: Result:='ibexportedmacros';
|
|
ibderefmap: Result:='ibderefmap';
|
|
{syms}
|
|
ibtypesym: Result:='ibtypesym';
|
|
ibprocsym: Result:='ibprocsym';
|
|
ibstaticvarsym: Result:='ibstaticvarsym';
|
|
ibconstsym: Result:='ibconstsym';
|
|
ibenumsym: Result:='ibenumsym';
|
|
ibtypedconstsym: Result:='ibtypedconstsym';
|
|
ibabsolutevarsym: Result:='ibabsolutevarsym';
|
|
ibpropertysym: Result:='ibpropertysym';
|
|
ibfieldvarsym: Result:='ibfieldvarsym';
|
|
ibunitsym: Result:='ibunitsym';
|
|
iblabelsym: Result:='iblabelsym';
|
|
ibsyssym: Result:='ibsyssym';
|
|
ibrttisym: Result:='ibrttisym';
|
|
iblocalvarsym: Result:='iblocalvarsym';
|
|
ibparavarsym: Result:='ibparavarsym';
|
|
ibmacrosym: Result:='ibmacrosym';
|
|
{definitions}
|
|
iborddef: Result:='iborddef';
|
|
ibpointerdef: Result:='ibpointerdef';
|
|
ibarraydef: Result:='ibarraydef';
|
|
ibprocdef: Result:='ibprocdef';
|
|
ibshortstringdef: Result:='ibshortstringdef';
|
|
ibrecorddef: Result:='ibrecorddef';
|
|
ibfiledef: Result:='ibfiledef';
|
|
ibformaldef: Result:='ibformaldef';
|
|
ibobjectdef: Result:='ibobjectdef';
|
|
ibenumdef: Result:='ibenumdef';
|
|
ibsetdef: Result:='ibsetdef';
|
|
ibprocvardef: Result:='ibprocvardef';
|
|
ibfloatdef: Result:='ibfloatdef';
|
|
ibclassrefdef: Result:='ibclassrefdef';
|
|
iblongstringdef: Result:='iblongstringdef';
|
|
ibansistringdef: Result:='ibansistringdef';
|
|
ibwidestringdef: Result:='ibwidestringdef';
|
|
ibvariantdef: Result:='ibvariantdef';
|
|
ibundefineddef: Result:='ibundefineddef';
|
|
ibunicodestringdef: Result:='ibunicodestringdef';
|
|
{implementation/ObjData}
|
|
ibnodetree: Result:='ibnodetree';
|
|
ibasmsymbols: Result:='ibasmsymbols';
|
|
ibresources: Result:='ibresources';
|
|
ibcreatedobjtypes:Result:='ibcreatedobjtypes';
|
|
ibwpofile: Result:='ibwpofile';
|
|
ibmoduleoptions: Result:='ibmoduleoptions';
|
|
|
|
ibmainname: Result:='ibmainname';
|
|
ibsymtableoptions:Result:='ibsymtableoptions';
|
|
//ibrecsymtableoptions: duplicate with ibsymtableoptions
|
|
{ target-specific things }
|
|
iblinkotherframeworks: Result:='iblinkotherframeworks';
|
|
ibjvmnamespace: Result:='ibjvmnamespace';
|
|
else Result:='unknown('+IntToStr(Entry)+')';
|
|
end;
|
|
end;
|
|
|
|
function ComparePPULinkedFiles(Item1, Item2: Pointer): integer;
|
|
var
|
|
File1: TPPULinkedFile absolute Item1;
|
|
File2: TPPULinkedFile absolute Item2;
|
|
begin
|
|
if File1.ID<File2.ID then exit(1)
|
|
else if File1.ID>File2.ID then exit(-1);
|
|
Result:=CompareFilenames(File1.Filename,File2.Filename);
|
|
if Result<>0 then exit;
|
|
if File1.Flags<File2.Flags then exit(1)
|
|
else if File1.Flags>File2.Flags then exit(-1);
|
|
Result:=0;
|
|
end;
|
|
|
|
{ EPPUParserError }
|
|
|
|
constructor EPPUParserError.Create(ASender: TPPU; const AMessage: string);
|
|
begin
|
|
Sender:=ASender;
|
|
inherited Create(AMessage);
|
|
end;
|
|
|
|
{ TPPU }
|
|
|
|
procedure TPPU.ReadPPU(const Parts: TPPUParts);
|
|
begin
|
|
ReadHeader;
|
|
|
|
// interface header
|
|
if ppInterfaceHeader in Parts then
|
|
ReadInterfaceHeader
|
|
else
|
|
SkipUntilEntry(ibendinterface);
|
|
|
|
if Version>=128 then
|
|
ReadSymTableOptions;
|
|
|
|
// interface definitions
|
|
if ppInterfaceDefinitions in Parts then
|
|
ReadDefinitions
|
|
else
|
|
SkipUntilEntry(ibenddefs);
|
|
|
|
// Interface Symbols
|
|
SkipUntilEntry(ibendsyms);
|
|
|
|
// Interface Macros
|
|
if ReadEntry=ibexportedmacros then begin
|
|
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;
|
|
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 Version>=128 then
|
|
ReadSymTableOptions;
|
|
if ppImplementationDefinitions in Parts then
|
|
ReadDefinitions
|
|
else
|
|
SkipUntilEntry(ibenddefs);
|
|
SkipUntilEntry(ibendsyms);
|
|
end else begin
|
|
// no definitions and no symbols
|
|
end;
|
|
end;
|
|
|
|
procedure TPPU.ReadHeader;
|
|
var
|
|
cpu: tsystemcpu;
|
|
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);
|
|
|
|
{$R-}
|
|
cpu:=tsystemcpu(FHeader.cpu);
|
|
if (cpu<low(tsystemcpu)) or (cpu>high(tsystemcpu)) then
|
|
cpu:=tsystemcpu(FHeader.cpu);
|
|
{$R+}
|
|
FSizeOfAInt:=CpuAluBitSize[cpu] div 8;
|
|
FSizeOfASizeInt:=CpuAddrBitSize[cpu] div 8;
|
|
|
|
{$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
|
|
FInterfaceHeaderPos:=FDataPos;
|
|
repeat
|
|
EntryNr:=ReadEntry;
|
|
{$IFDEF VerbosePPUParser}
|
|
DebugLn(['TPPU.ReadInterface EntryNr=',EntryNr,'=',PPUEntryName(EntryNr)]);
|
|
{$ENDIF}
|
|
case EntryNr of
|
|
|
|
ibmodulename:
|
|
begin
|
|
{$IFDEF VerbosePPUParser}ModuleName:={$ENDIF}ReadEntryShortstring;
|
|
{$IFDEF VerbosePPUParser}
|
|
DebugLn(['TPPU.ReadInterfaceHeader ModuleName=',ModuleName]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
ibmoduleoptions:
|
|
ReadModuleOptions;
|
|
|
|
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,
|
|
iblinkotherframeworks:
|
|
ReadLinkContainer(EntryNr);
|
|
|
|
ibresources:
|
|
ReadResources;
|
|
|
|
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
|
|
FImplementationHeaderPos:=FDataPos;
|
|
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;
|
|
ImplProcOptions: timplprocoptions;
|
|
CurEntryStart: LongInt;
|
|
HasInliningInfo: Boolean;
|
|
begin
|
|
EntryNr:=ReadEntry;
|
|
if EntryNr<>ibstartdefs then
|
|
begin
|
|
Error('expected ibstartdefs, but found '+PPUEntryName(EntryNr));
|
|
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_dispid in procoptions) then
|
|
ReadEntryLongint{$IFDEF VerbosePPUParser}(' DispID : '){$ENDIF};
|
|
if Version>=167 then
|
|
ReadProcImplOptions(ImplProcOptions);
|
|
|
|
HasInliningInfo:=
|
|
((Version<167) and (po_has_inlininginfo in procoptions))
|
|
or ((Version>=167) and (pio_has_inlininginfo in implprocoptions));
|
|
if HasInliningInfo then begin
|
|
{$IFDEF VerbosePPUParser} dbgout(' FuncretSym : '); {$ENDIF}
|
|
ReadDereference;
|
|
ReadEntrySmallSet(procinfooptions);
|
|
{$IFDEF VerbosePPUParser} debugln([' ProcInfoOptions : ',dword(procinfooptions)]);{$ENDIF}
|
|
end;
|
|
// parast
|
|
if Version>=128 then
|
|
ReadSymTableOptions;
|
|
ReadDefinitions;
|
|
ReadSymbols;
|
|
// localst
|
|
if HasInliningInfo then
|
|
begin
|
|
ReadDefinitions;
|
|
ReadSymbols;
|
|
end;
|
|
if HasInliningInfo 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.ReadProcImplOptions(out ImplProcOptions: timplprocoptions);
|
|
begin
|
|
ReadEntrySmallSet(ImplProcOptions);
|
|
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;
|
|
genconstr: tgenericconstraintflags;
|
|
len: Int64;
|
|
i: Integer;
|
|
{$IFDEF VerbosePPUParser}
|
|
defopt: tdefoption;
|
|
defstate: tdefstate;
|
|
TokenBuf: Pointer;
|
|
TokenBufSize: LongInt;
|
|
{$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_genconstraint in defoptions then begin
|
|
// generic constraints
|
|
ReadEntrySmallSet(genconstr);
|
|
len:=ReadEntryASizeInt({$IFDEF VerbosePPUParser}'generic consstraints='{$ENDIF});
|
|
for i:=1 to len do begin
|
|
ReadDereference;
|
|
end;
|
|
end;
|
|
|
|
if [df_generic,df_specialization]*defoptions<>[] then begin
|
|
// generic parameters
|
|
len:=ReadEntryLongint;
|
|
for i:=1 to len do begin
|
|
ReadDereference;
|
|
end;
|
|
end;
|
|
|
|
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;
|
|
p: PByte;
|
|
{$IFDEF VerbosePPUParser}
|
|
po: tprocoption;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF VerbosePPUParser}
|
|
dbgout('Return type: ');
|
|
{$ENDIF}
|
|
ReadDereference;
|
|
if Version<169 then
|
|
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);
|
|
if Version>=167 then begin
|
|
// po_has_inlininginfo was deleted in PPU version 167
|
|
p:=@PByte(@procoptions)[ord(po_has_inlininginfo)];
|
|
System.Move(p[0],p[1],ord(High(procoptions))-ord(po_has_inlininginfo));
|
|
p^:=0;
|
|
end;
|
|
|
|
{$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;
|
|
if po_syscall_has_libsym in procoptions then
|
|
ReadDereference;
|
|
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=-1 then begin
|
|
{$IFDEF VerbosePPUParser}
|
|
dbgout(' Nil');
|
|
{$ENDIF}
|
|
exit;
|
|
end;
|
|
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
|
|
}
|
|
fileindex:=0;
|
|
line:=0;
|
|
column:=0;
|
|
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;
|
|
|
|
procedure TPPU.ReadSymTableOptions;
|
|
var
|
|
Nr: Byte;
|
|
s: DWord;
|
|
begin
|
|
Nr:=ReadEntry;
|
|
if Nr<>ibsymtableoptions then
|
|
Error('expected ibsymtableoptions, but found '+PPUEntryName(Nr));
|
|
ReadEntrySmallSet(s);
|
|
end;
|
|
|
|
function TPPU.ReadEntry: byte;
|
|
|
|
procedure ErrorInvalidTypeID;
|
|
begin
|
|
Error('Invalid entry type-id '+IntToStr(FEntry.id));
|
|
end;
|
|
|
|
begin
|
|
FEntryPos:=0;
|
|
FEntryStart:=FDataPos;
|
|
ReadData(FEntry,SizeOf(FEntry));
|
|
if fChangeEndian then
|
|
FEntry.size:=SwapEndian(FEntry.size);
|
|
{$IFDEF VerbosePPUParser}
|
|
//DebugLn(['TPPU.ReadEntry nr=',FEntry.Nr,'=',PPUEntryName(FEntry.nr),' streampos=',FDataPos,' type-id=',FEntry.id]);
|
|
{$ENDIF}
|
|
if not (FEntry.id in [mainentryid,subentryid]) then
|
|
ErrorInvalidTypeID;
|
|
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 = 16384;
|
|
var
|
|
NewSize: Integer;
|
|
begin
|
|
NewSize:=FDataPos+Add;
|
|
if NewSize<=FDataSize then exit;
|
|
// need grow
|
|
if FDataSize<InitialSize then
|
|
FDataSize:=InitialSize
|
|
else
|
|
FDataSize:=FDataSize*2;
|
|
while FDataSize<NewSize do begin
|
|
if FDataSize>100000000 then
|
|
Error('ppu too big');
|
|
FDataSize:=FDataSize*2;
|
|
end;
|
|
ReAllocMem(FData,FDataSize);
|
|
end;
|
|
|
|
function Read(Count: integer): Pointer;
|
|
var
|
|
ReadCount: LongInt;
|
|
begin
|
|
//DebugLn(['Read Count=',Count,' Pos=',FDataPos]);
|
|
// read and copy some more data to FData
|
|
Grow(Count);
|
|
Result:=Pointer(FData+FDataPos);
|
|
ReadCount:=s.Read(Result^,Count);
|
|
if ReadCount<Count then
|
|
Error('ppu too short, buggy ppu');
|
|
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;
|
|
if fChangeEndian then
|
|
Entry^.Size:=SwapEndian(Entry^.Size);
|
|
if Entry^.Size<0 then
|
|
Error('entry has negative size');
|
|
Read(Entry^.Size);
|
|
end;
|
|
|
|
function ReadUntilEntry(EntryNr: byte): boolean;
|
|
var
|
|
b: Byte;
|
|
begin
|
|
repeat
|
|
b:=ReadEntryBlock;
|
|
if b=ibend then exit(false);
|
|
until (b=EntryNr) and (Entry^.id=mainentryid);
|
|
Result:=true;
|
|
end;
|
|
|
|
var
|
|
p: Pointer;
|
|
begin
|
|
fChangeEndian:=PPUIsEndianBig;
|
|
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
|
|
if not ReadUntilEntry(ibendinterface) then
|
|
Error('missing end of interface');
|
|
if not ReadUntilEntry(ibenddefs) then
|
|
Error('missing end of interface definitions');
|
|
if not ReadUntilEntry(ibendsyms) then
|
|
Error('missing end of interface symbols');
|
|
if ReadEntryBlock=ibexportedmacros then begin
|
|
if boolean(PByte(PByte(Entry)+SizeOf(TPPUEntry))^) then begin
|
|
if not ReadUntilEntry(ibenddefs) then
|
|
Error('missing end of macro definitions');
|
|
if not ReadUntilEntry(ibendsyms) then
|
|
Error('missing end of macro symbols');
|
|
end;
|
|
end;
|
|
if not ReadUntilEntry(ibendimplementation) then
|
|
Error('missing end of implementation');
|
|
if (FHeader.flags and uf_local_symtable)<>0 then begin
|
|
if not ReadUntilEntry(ibenddefs) then
|
|
Error('missing end of implementation definitions');
|
|
if not ReadUntilEntry(ibendsyms) then
|
|
Error('missing end of implementation symbols');
|
|
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;
|
|
|
|
procedure ErrorOutOfBytes;
|
|
begin
|
|
Error('TPPU.ReadEntryShortstring: out of bytes. needed='+IntToStr(l)+', found='+IntToStr(FEntry.size-FEntryPos));
|
|
end;
|
|
|
|
begin
|
|
l:=ReadEntryByte;
|
|
s[0]:=chr(l);
|
|
if l>0 then begin
|
|
if FEntryPos+l>FEntry.size then
|
|
ErrorOutOfBytes;
|
|
System.Move(Pointer(FEntryBuf+FEntryPos)^,s[1],l);
|
|
end;
|
|
Result:=s;
|
|
inc(FEntryPos,l);
|
|
end;
|
|
|
|
function TPPU.ReadEntryShortstring(const Msg: string): shortstring;
|
|
begin
|
|
Result:=ReadEntryShortstring();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryAnsistring: ansistring;
|
|
var
|
|
l: longint;
|
|
|
|
procedure ErrorOutOfBytes;
|
|
begin
|
|
Error('TPPU.ReadEntryAnsistring: out of bytes. needed='+IntToStr(l)+', found='+IntToStr(FEntry.size-FEntryPos));
|
|
end;
|
|
|
|
begin
|
|
l:=ReadEntryLongint;
|
|
SetLength(Result,l);
|
|
if l>0 then begin
|
|
if FEntryPos+l>FEntry.size then
|
|
ErrorOutOfBytes;
|
|
System.Move(Pointer(FEntryBuf+FEntryPos)^,Result[1],l);
|
|
end;
|
|
inc(FEntryPos,l);
|
|
end;
|
|
|
|
function TPPU.ReadEntryAnsistring(const Msg: string): ansistring;
|
|
begin
|
|
Result:=ReadEntryAnsistring();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryLongint: longint;
|
|
begin
|
|
if FEntryPos+SizeOf(Longint)>FEntry.size then
|
|
Error('TPPU.ReadEntryLongint: out of bytes');
|
|
Result:=PLongint(FEntryBuf+FEntryPos)^;
|
|
inc(FEntryPos,SizeOf(Longint));
|
|
end;
|
|
|
|
function TPPU.ReadEntryLongint(const Msg: string): longint;
|
|
begin
|
|
Result:=ReadEntryLongint();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryDWord: cardinal;
|
|
begin
|
|
Result:=cardinal(ReadEntryLongint);
|
|
end;
|
|
|
|
function TPPU.ReadEntryDWord(const Msg: string): cardinal;
|
|
begin
|
|
Result:=cardinal(ReadEntryLongint(Msg));
|
|
end;
|
|
|
|
function TPPU.ReadEntryWord: word;
|
|
begin
|
|
if FEntryPos+SizeOf(Word)>FEntry.size then
|
|
Error('TPPU.ReadEntryLongint: out of bytes');
|
|
Result:=PWord(FEntryBuf+FEntryPos)^;
|
|
inc(FEntryPos,SizeOf(Word));
|
|
end;
|
|
|
|
function TPPU.ReadEntryWord(const Msg: string): word;
|
|
begin
|
|
Result:=ReadEntryWord();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryInt64: int64;
|
|
begin
|
|
if FEntryPos+SizeOf(Int64)>FEntry.size then
|
|
Error('TPPU.ReadEntryInt64: out of bytes');
|
|
Result:=PInt64(FEntryBuf+FEntryPos)^;
|
|
inc(FEntryPos,SizeOf(Int64));
|
|
end;
|
|
|
|
function TPPU.ReadEntryInt64(const Msg: string): int64;
|
|
begin
|
|
Result:=ReadEntryInt64();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryQWord: QWord;
|
|
begin
|
|
if FEntryPos+SizeOf(QWord)>FEntry.size then
|
|
Error('TPPU.ReadEntryQWord: out of bytes');
|
|
Result:=PQWord(FEntryBuf+FEntryPos)^;
|
|
inc(FEntryPos,SizeOf(QWord));
|
|
end;
|
|
|
|
function TPPU.ReadEntryQWord(const Msg: string): QWord;
|
|
begin
|
|
Result:=ReadEntryQWord();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryAInt: int64;
|
|
begin
|
|
case FSizeOfAInt of
|
|
8: result:=ReadEntryInt64;
|
|
4: result:=ReadEntryLongint;
|
|
2: result:=smallint(ReadEntryWord);
|
|
1: result:=shortint(ReadEntryByte);
|
|
else
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
function TPPU.ReadEntryAInt(const Msg: string): int64;
|
|
begin
|
|
Result:=ReadEntryAInt();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
function TPPU.ReadEntryASizeInt: int64;
|
|
begin
|
|
case FSizeOfASizeInt of
|
|
8: result:=ReadEntryInt64;
|
|
4: result:=ReadEntryLongint;
|
|
2: result:=smallint(ReadEntryWord);
|
|
1: result:=shortint(ReadEntryByte);
|
|
else
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
function TPPU.ReadEntryASizeInt(const Msg: string): int64;
|
|
begin
|
|
Result:=ReadEntryASizeInt();
|
|
debugln([Msg,Result]);
|
|
end;
|
|
|
|
procedure TPPU.ReadEntrySmallSet(out s);
|
|
var
|
|
i: longint;
|
|
begin
|
|
if FEntryPos+4>FEntry.size then
|
|
Error('TPPU.ReadEntryLongint: out of bytes');
|
|
System.Move(PByte(FEntryBuf+FEntryPos)^,s{%H-},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(out s);
|
|
var
|
|
i: longint;
|
|
begin
|
|
if FEntryPos+32>FEntry.size then
|
|
Error('TPPU.ReadEntryLongint: out of bytes');
|
|
System.Move(PByte(FEntryBuf+FEntryPos)^,s{%H-},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: DWord;
|
|
IntfCRC: DWord;
|
|
IndirectCRC: DWord;
|
|
{$ENDIF}
|
|
begin
|
|
while not EndOfEntry do begin
|
|
{$IFDEF VerbosePPUParser}AUnitName:={$ENDIF}ReadEntryShortstring;
|
|
{$IFDEF VerbosePPUParser}CRC:={$ENDIF}ReadEntryDWord;
|
|
{$IFDEF VerbosePPUParser}IntfCRC:={$ENDIF}ReadEntryDWord;
|
|
if FVersion>=107 then begin
|
|
// svn rev 14503 ppu ver 107
|
|
{$IFDEF VerbosePPUParser}IndirectCRC:={$ENDIF}ReadEntryDWord;
|
|
end else begin
|
|
{$IFDEF VerbosePPUParser}IndirectCRC:=0;{$ENDIF}
|
|
end;
|
|
{$IFDEF VerbosePPUParser}
|
|
DebugLn(['TPPU.ReadUsedUnits Unit=',AUnitName,' CRC=',HexStr(cardinal(CRC),8),' IntfCRC=',HexStr(cardinal(IntfCRC),8),' IndCRC=',HexStr(cardinal(IndirectCRC),8)]);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TPPU.ReadModuleOptions;
|
|
type
|
|
tmoduleoption = (
|
|
mo_none,
|
|
mo_hint_deprecated,
|
|
mo_hint_platform,
|
|
mo_hint_library,
|
|
mo_hint_unimplemented,
|
|
mo_hint_experimental,
|
|
mo_has_deprecated_msg
|
|
);
|
|
tmoduleoptions = set of tmoduleoption;
|
|
{$IFDEF VerbosePPUParser}
|
|
type
|
|
tmoduleopt=record
|
|
mask : tmoduleoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
moduleopts=6;
|
|
moduleopt : array[1..moduleopts] of tmoduleopt=(
|
|
(mask:mo_hint_deprecated; str:'Hint Deprecated'),
|
|
(mask:mo_hint_platform; str:'Hint Platform'),
|
|
(mask:mo_hint_library; str:'Hint Library'),
|
|
(mask:mo_hint_unimplemented; str:'Hint Unimplemented'),
|
|
(mask:mo_hint_experimental; str:'Hint Experimental'),
|
|
(mask:mo_has_deprecated_msg; str:'Has Deprecated Message')
|
|
);
|
|
{$ENDIF}
|
|
var
|
|
moduleoptions : tmoduleoptions;
|
|
{$IFDEF VerbosePPUParser}
|
|
i : longint;
|
|
first : boolean;
|
|
{$ENDIF}
|
|
begin
|
|
ReadEntrySmallSet(moduleoptions);
|
|
{$IFDEF VerbosePPUParser}
|
|
if moduleoptions<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to moduleopts do
|
|
if (moduleopt[i].mask in moduleoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
dbgout(', ');
|
|
dbgout(moduleopt[i].str);
|
|
end;
|
|
debugln;
|
|
end;
|
|
{$ENDIF}
|
|
if mo_has_deprecated_msg in moduleoptions then begin
|
|
ReadEntryShortstring{$IFDEF VerbosePPUParser}('Deprecated : '){$ENDIF};
|
|
end;
|
|
end;
|
|
|
|
procedure TPPU.ReadLinkContainer(aContainerType: byte);
|
|
{$IFDEF VerbosePPUParser}
|
|
var
|
|
Desc: String;
|
|
var
|
|
Filename: ShortString;
|
|
Flags: LongInt;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFNDEF VerbosePPUParser}
|
|
if aContainerType=0 then ;
|
|
{$ENDIF}
|
|
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: ';
|
|
iblinkotherframeworks:
|
|
Desc:='Link framework: ';
|
|
end;
|
|
Desc:=Desc+Filename+' '+PPULinkContainerFlagToStr(Flags);
|
|
DebugLn(['TPPU.ReadLinkContainer ',Desc]);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TPPU.ReadResources;
|
|
{$IFDEF VerbosePPUParser}
|
|
var
|
|
Filename: ShortString;
|
|
{$ENDIF}
|
|
begin
|
|
while not EndOfEntry do begin
|
|
{$IFDEF VerbosePPUParser}Filename:={$ENDIF}ReadEntryShortstring;
|
|
{$IFDEF VerbosePPUParser}
|
|
DebugLn(['TPPU.ReadResources file: '+Filename]);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TPPU.ReadImportSymbols;
|
|
var
|
|
SymbolCount: LongInt;
|
|
i: Integer;
|
|
{$IFDEF VerbosePPUParser}
|
|
LibName: ShortString;
|
|
SymbolName: ShortString;
|
|
SymbolOrdNr: LongInt;
|
|
SymbolIsVar: Boolean;
|
|
SymMangledName: String;
|
|
{$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;
|
|
if Version>130 then
|
|
{$IFDEF VerbosePPUParser}SymMangledName:={$ENDIF}ReadEntryShortstring
|
|
else
|
|
{$IFDEF VerbosePPUParser}SymMangledName:=SymbolName{$ENDIF};
|
|
{$IFDEF VerbosePPUParser}SymbolOrdNr:={$ENDIF}ReadEntryLongint;
|
|
{$IFDEF VerbosePPUParser}SymbolIsVar:=ReadEntryByte<>0{$ELSE}ReadEntryByte{$ENDIF};
|
|
{$IFDEF VerbosePPUParser}
|
|
DebugLn(['TPPU.ReadImportSymbols "',SymbolName,'" Mangled="',SymMangledName,'" (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
|
|
{$IFDEF VerbosePPUParser}
|
|
CTDumpStack;
|
|
{$ENDIF}
|
|
raise EPPUParserError.Create(Self,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);
|
|
ReadEntryDWord; // CRC
|
|
ReadEntryDWord; // IntfCRC
|
|
if FVersion>=107 then ReadEntryDWord;
|
|
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(TheOwner: TObject);
|
|
begin
|
|
FOwner:=TheOwner;
|
|
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;
|
|
|
|
FInterfaceHeaderPos:=0;
|
|
FMainUsesSectionPos:=0;
|
|
FImplementationHeaderPos:=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: TFileStreamUTF8;
|
|
begin
|
|
fs:=TFileStreamUTF8.Create(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]);
|
|
DebugLn([Prefix,' Indirect Checksum=',HexStr(cardinal(FHeader.indirect_checksum),8)]);
|
|
DebugLn([Prefix,' sizeof(aint)=',FSizeOfAInt]);
|
|
end;
|
|
|
|
procedure TPPU.GetMainUsesSectionNames(var List: TStrings);
|
|
begin
|
|
GetUsesSection(FMainUsesSectionPos,List);
|
|
end;
|
|
|
|
procedure TPPU.GetImplementationUsesSectionNames(var List: TStrings);
|
|
begin
|
|
GetUsesSection(FImplementationUsesSectionPos,List);
|
|
end;
|
|
|
|
procedure TPPU.GetLinkedFiles(var ListOfTPPULinkedFile: TObjectList);
|
|
var
|
|
EntryNr: Byte;
|
|
Item: TPPULinkedFile;
|
|
Filename: String;
|
|
Flags: LongInt;
|
|
begin
|
|
if FInterfaceHeaderPos=0 then exit;
|
|
SetDataPos(FInterfaceHeaderPos);
|
|
repeat
|
|
EntryNr:=ReadEntry;
|
|
case EntryNr of
|
|
iblinkunitofiles,iblinkunitstaticlibs,iblinkunitsharedlibs,
|
|
iblinkotherofiles,iblinkotherstaticlibs,iblinkothersharedlibs,
|
|
iblinkotherframeworks:
|
|
begin
|
|
while not EndOfEntry do begin
|
|
Filename:=ReadEntryShortstring;
|
|
Flags:=ReadEntryLongint;
|
|
//debugln(['TPPU.GetLinkedFiles ',PPUEntryName(EntryNr),' ',Filename]);
|
|
if ListOfTPPULinkedFile=nil then
|
|
ListOfTPPULinkedFile:=TObjectList.Create(true);
|
|
Item:=TPPULinkedFile.Create;
|
|
Item.ID:=EntryNr;
|
|
Item.Filename:=Filename;
|
|
Item.Flags:=Flags;
|
|
ListOfTPPULinkedFile.Add(Item);
|
|
end;
|
|
end;
|
|
|
|
ibendinterface:
|
|
break;
|
|
|
|
else
|
|
FEntryPos:=FEntry.size;
|
|
end;
|
|
until false;
|
|
end;
|
|
|
|
function TPPU.GetInitProcName: string;
|
|
begin
|
|
Result:=GetProcMangledName(FInitProcPos);
|
|
end;
|
|
|
|
function TPPU.GetFinalProcName: string;
|
|
begin
|
|
Result:=GetProcMangledName(FFinalProcPos);
|
|
end;
|
|
|
|
end.
|
|
|