mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 14:24:24 +02:00
05b73f1523
This commit does 3 changes: 1. Introduce new option `oo_inherits_not_specialized` indicating if somewhere in the inheritance chain of an object there is a non specialized generic parameter 2. Avoid building the VMT for an object which has a generic parameter in the inheritance chain (fixes #40983) 3. When no vmt is build `insert_struct_hidden_paras` usually called as part of `build_vmt` will be called seperately to add missing parameters
5422 lines
172 KiB
ObjectPascal
5422 lines
172 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2020 by the FPC Development Team
|
|
|
|
Dumps the contents of a FPC unit file (PPU File)
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************}
|
|
program ppudump;
|
|
|
|
{$i fpcdefs.inc}
|
|
{$H+}
|
|
{$packenum 1}
|
|
|
|
{$define IN_PPUDUMP}
|
|
uses
|
|
{ do NOT add symconst or globtype to make merging easier }
|
|
{ do include symconst and globtype now before splitting 2.5 PM 2011-06-15 }
|
|
cutils,
|
|
SysUtils,
|
|
constexp,
|
|
symconst,
|
|
ppu,
|
|
entfile,
|
|
systems,
|
|
cpuinfo,
|
|
globals,
|
|
globtype,
|
|
widestr,
|
|
tokens,
|
|
version,
|
|
ppuout,
|
|
ppujson,
|
|
ppuxml;
|
|
|
|
const
|
|
Title = 'PPU-Analyser';
|
|
Copyright = 'Copyright (c) 1998-2020 by the Free Pascal Development Team';
|
|
|
|
{ verbosity }
|
|
v_none = $0;
|
|
v_header = $1;
|
|
v_defs = $2;
|
|
v_syms = $4;
|
|
v_interface = $8;
|
|
v_implementation = $10;
|
|
// v_browser = $20;
|
|
v_all = $ff;
|
|
|
|
{ not needed anymore $i systems.inc }
|
|
|
|
{ List of all supported cpus }
|
|
const
|
|
CpuTxt : array[tsystemcpu] of string[16]=
|
|
(
|
|
{ 0 } 'none',
|
|
{ 1 } 'i386',
|
|
{ 2 } 'm68k',
|
|
{ 3 } 'alpha (obsolete)',
|
|
{ 4 } 'powerpc',
|
|
{ 5 } 'sparc',
|
|
{ 6 } 'vis (obsolete)',
|
|
{ 7 } 'ia64 (obsolete)',
|
|
{ 8 } 'x86_64',
|
|
{ 9 } 'mipseb',
|
|
{ 10 } 'arm',
|
|
{ 11 } 'powerpc64',
|
|
{ 12 } 'avr',
|
|
{ 13 } 'mipsel',
|
|
{ 14 } 'jvm',
|
|
{ 15 } 'i8086',
|
|
{ 16 } 'aarch64',
|
|
{ 17 } 'wasm32',
|
|
{ 18 } 'sparc64',
|
|
{ 19 } 'riscv32',
|
|
{ 20 } 'riscv64',
|
|
{ 21 } 'xtensa',
|
|
{ 22 } 'z80',
|
|
{ 23 } 'mips64',
|
|
{ 24 } 'mips64el',
|
|
{ 25 } 'loongarch64'
|
|
);
|
|
|
|
CpuHasController : array[tsystemcpu] of boolean =
|
|
(
|
|
{ 0 } false {'none'},
|
|
{ 1 } false {'i386'},
|
|
{ 2 } false {'m68k'},
|
|
{ 3 } false {'alpha (obsolete)'},
|
|
{ 4 } false {'powerpc'},
|
|
{ 5 } false {'sparc'},
|
|
{ 6 } false {'vis (obsolete)'},
|
|
{ 7 } false {'ia64 (obsolete)'},
|
|
{ 8 } false {'x86_64'},
|
|
{ 9 } false {'mipseb'},
|
|
{ 10 } true {'arm'},
|
|
{ 11 } false {'powerpc64'},
|
|
{ 12 } true {'avr'},
|
|
{ 13 } true {'mipsel'},
|
|
{ 14 } false {'jvm'},
|
|
{ 15 } false {'i8086'},
|
|
{ 16 } false {'aarch64'},
|
|
{ 17 } false {'wasm32'},
|
|
{ 18 } false {'sparc64'},
|
|
{ 19 } false {'riscv32'},
|
|
{ 20 } false {'riscv64'},
|
|
{ 21 } true {'xtensa'},
|
|
{ 22 } true {'z80'},
|
|
{ 23 } false {'mips64'},
|
|
{ 24 } false {'mips64el'},
|
|
{ 25 } false {'loongarch64'}
|
|
);
|
|
|
|
{ List of all supported system-cpu couples }
|
|
const
|
|
Targets : array[tsystem] of string[26]=(
|
|
{ 0 } 'none',
|
|
{ 1 } 'GO32V1 (obsolete)',
|
|
{ 2 } 'GO32V2',
|
|
{ 3 } 'Linux-i386',
|
|
{ 4 } 'OS/2',
|
|
{ 5 } 'Win32',
|
|
{ 6 } 'FreeBSD-i386',
|
|
{ 7 } 'Amiga',
|
|
{ 8 } 'Atari',
|
|
{ 9 } 'MacOSClassic-m68k',
|
|
{ 10 } 'Linux-m68k',
|
|
{ 11 } 'PalmOS-m68k',
|
|
{ 12 } 'Linux-alpha (obsolete)',
|
|
{ 13 } 'Linux-ppc',
|
|
{ 14 } 'MacOSClassic-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 (obsolete)',
|
|
{ 26 } 'Linux-x86-64',
|
|
{ 27 } 'Darwin-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 (obsolete)',
|
|
{ 40 } 'WinCE-i386',
|
|
{ 41 } 'Linux-x64',
|
|
{ 42 } 'GBA-arm',
|
|
{ 43 } 'Linux-powerpc64',
|
|
{ 44 } 'Darwin-i386',
|
|
{ 45 } 'PalmOS-arm',
|
|
{ 46 } 'Darwin-powerpc64',
|
|
{ 47 } 'NDS-arm',
|
|
{ 48 } 'Embedded-i386',
|
|
{ 49 } 'Embedded-m68k',
|
|
{ 50 } 'Embedded-alpha (obsolete)',
|
|
{ 51 } 'Embedded-powerpc',
|
|
{ 52 } 'Embedded-sparc',
|
|
{ 53 } 'Embedded-vm (obsolete)',
|
|
{ 54 } 'Embedded-iA64 (obsolete)',
|
|
{ 55 } 'Embedded-x64',
|
|
{ 56 } 'Embedded-mips',
|
|
{ 57 } 'Embedded-arm',
|
|
{ 58 } 'Embedded-powerpc64',
|
|
{ 59 } 'Symbian-i386',
|
|
{ 60 } 'Symbian-arm',
|
|
{ 61 } 'Darwin-x64',
|
|
{ 62 } 'Embedded-avr',
|
|
{ 63 } 'Haiku-i386',
|
|
{ 64 } 'iOS-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',
|
|
{ 86 } 'iOS-AArch64',
|
|
{ 87 } 'iPhoneSim-x86-64',
|
|
{ 88 } 'Linux-AArch64',
|
|
{ 89 } 'Win16',
|
|
{ 90 } 'Embedded-i8086',
|
|
{ 91 } 'AROS-arm',
|
|
{ 92 } 'WebAssembly-wasm',
|
|
{ 93 } 'Linux-sparc64',
|
|
{ 94 } 'Solaris-sparc64',
|
|
{ 95 } 'NetBSD-arm',
|
|
{ 96 } 'Linux-RiscV32',
|
|
{ 97 } 'Linux-RiscV64',
|
|
{ 98 } 'Embedded-RiscV32',
|
|
{ 99 } 'Embedded-RiscV64',
|
|
{ 100 } 'Android-AArch64',
|
|
{ 101 } 'Android-x86-64',
|
|
{ 102 } 'Haiku-x86-64',
|
|
{ 103 } 'Embedded-Xtensa',
|
|
{ 104 } 'FreeRTos-Xtensa',
|
|
{ 105 } 'Linux-Xtensa',
|
|
{ 106 } 'FreeRTos-arm',
|
|
{ 107 } 'Win64-AArch64',
|
|
{ 108 } 'Embedded-Z80',
|
|
{ 109 } 'ZXSpectrum-Z80',
|
|
{ 110 } 'MSX-DOS-Z80',
|
|
{ 111 } 'Darwin-AArch64',
|
|
{ 112 } 'AmstradCPC-Z80',
|
|
{ 113 } 'SinclairQL-m68k',
|
|
{ 114 } 'WASI-WASM32',
|
|
{ 115 } 'FreeBSD-AArch64',
|
|
{ 116 } 'Embedded-aarch64',
|
|
{ 117 } 'Linux-MIPS64',
|
|
{ 118 } 'Linux-MIPS64el',
|
|
{ 119 } 'FreeRTos-RiscV32',
|
|
{ 120 } 'Linux-LoongArch64',
|
|
{ 121 } 'iPhoneSim-AArch64',
|
|
{ 122 } 'Human68k-m68k',
|
|
{ 123 } 'PS1-mipsel'
|
|
);
|
|
|
|
const
|
|
{ in widestr, we have the following definition
|
|
type
|
|
tcompilerwidechar = word;
|
|
thus widecharsize seems to always be 2 bytes }
|
|
|
|
widecharsize : longint = 2;
|
|
cpu : tsystemcpu = cpu_no;
|
|
|
|
{ This type is defined in scanner.pas unit }
|
|
type
|
|
tspecialgenerictoken = (
|
|
ST_LOADSETTINGS,
|
|
ST_LINE,
|
|
ST_COLUMN,
|
|
ST_FILEINDEX,
|
|
ST_LOADMESSAGES,
|
|
ST_INVALID);
|
|
|
|
type
|
|
tcpu_i386 = (
|
|
cpu_variant_i386_none,
|
|
cpu_variant_386,
|
|
cpu_variant_486,
|
|
cpu_variant_Pentium,
|
|
cpu_variant_Pentium2,
|
|
cpu_variant_Pentium3,
|
|
cpu_variant_Pentium4,
|
|
cpu_variant_PentiumM,
|
|
cpu_variant_core_i,
|
|
cpu_variant_core_avx,
|
|
cpu_variant_core_avx2);
|
|
|
|
tcpu_m68k = (
|
|
cpu_variant_m68k_none,
|
|
cpu_variant_MC68000,
|
|
cpu_variant_MC68020,
|
|
cpu_variant_MC68040,
|
|
cpu_variant_MC68060,
|
|
cpu_variant_isa_a,
|
|
cpu_variant_isa_a_p,
|
|
cpu_variant_isa_b,
|
|
cpu_variant_isa_c,
|
|
cpu_variant_cfv4e
|
|
);
|
|
|
|
tcpu_powerpc = (
|
|
cpu_variant_powerpc_none,
|
|
cpu_variant_ppc604,
|
|
cpu_variant_ppc750,
|
|
cpu_variant_ppc7400,
|
|
cpu_variant_ppc970
|
|
);
|
|
|
|
tcpu_sparc = (
|
|
cpu_variant_sparc_none,
|
|
cpu_variant_SPARC_V7,
|
|
cpu_variant_SPARC_V8,
|
|
cpu_variant_SPARC_V9
|
|
);
|
|
|
|
tcpu_x86_64 = (
|
|
cpu_variant_x86_64_none,
|
|
cpu_variant_athlon64,
|
|
cpu_variant_x86_64_core_i,
|
|
cpu_variant_x86_64_core_avx,
|
|
cpu_variant_x86_64_core_avx2
|
|
);
|
|
|
|
tcpu_mipseb = (
|
|
cpu_variant_mipseb_none,
|
|
cpu_variant_mips1,
|
|
cpu_variant_mips2,
|
|
cpu_variant_mips3,
|
|
cpu_variant_mips4,
|
|
cpu_variant_mips5,
|
|
cpu_variant_mips32,
|
|
cpu_variant_mips32r2,
|
|
cpu_variant_pic32mx
|
|
);
|
|
|
|
tcpu_arm = (
|
|
cpu_variant_arm_none,
|
|
cpu_variant_armv3,
|
|
cpu_variant_armv4,
|
|
cpu_variant_armv4t,
|
|
cpu_variant_armv5,
|
|
cpu_variant_armv5t,
|
|
cpu_variant_armv5te,
|
|
cpu_variant_armv5tej,
|
|
cpu_variant_armv6,
|
|
cpu_variant_armv6k,
|
|
cpu_variant_armv6t2,
|
|
cpu_variant_armv6z,
|
|
cpu_variant_armv6m,
|
|
cpu_variant_armv7,
|
|
cpu_variant_armv7a,
|
|
cpu_variant_armv7r,
|
|
cpu_variant_armv7m,
|
|
cpu_variant_armv7em
|
|
);
|
|
|
|
tcpu_powerpc64 = (
|
|
cpu_variant_powerpc64_none,
|
|
cpu_variant_powerpc64_ppc970
|
|
);
|
|
|
|
tcpu_avr = (
|
|
cpu_variant_avr_none,
|
|
cpu_variant_avr1,
|
|
cpu_variant_avr2,
|
|
cpu_variant_avr25,
|
|
cpu_variant_avr3,
|
|
cpu_variant_avr31,
|
|
cpu_variant_avr35,
|
|
cpu_variant_avr4,
|
|
cpu_variant_avr5,
|
|
cpu_variant_avr51,
|
|
cpu_variant_avr6
|
|
);
|
|
|
|
tcpu_mipsel = tcpu_mipseb;
|
|
|
|
tcpu_jvm = (
|
|
cpu_variant_jvm_none,
|
|
{ jvm, same as cpu_none }
|
|
cpu_variant_jvm,
|
|
{ jvm byte code to be translated into Dalvik bytecode: more type-
|
|
sensitive }
|
|
cpu_variant_dalvik
|
|
);
|
|
|
|
tcpu_i8086 = (
|
|
cpu_variant_i8086_none,
|
|
cpu_variant_8086,
|
|
cpu_variant_186,
|
|
cpu_variant_286,
|
|
cpu_variant_i8086_386,
|
|
cpu_variant_i8086_486,
|
|
cpu_variant_i8086_Pentium,
|
|
cpu_variant_i8086_Pentium2,
|
|
cpu_variant_i8086_Pentium3,
|
|
cpu_variant_i8086_Pentium4,
|
|
cpu_variant_i8086_PentiumM
|
|
);
|
|
|
|
tcpu_aarch64 = (
|
|
cpu_variant_aarch64_none,
|
|
cpu_variant_armv8
|
|
);
|
|
|
|
tcpu_wasm32 = (
|
|
cpu_variant_wasm32_none);
|
|
|
|
tcpu_sparc64 = (
|
|
cpu_variant_sparc64_none,
|
|
cpu_variant_SPARC64_V9
|
|
);
|
|
|
|
tcpu_riscv32 = (
|
|
cpu_variant_riscv32_none,
|
|
cpu_variant_rv32imafd,
|
|
cpu_variant_rv32ima,
|
|
cpu_variant_rv32im,
|
|
cpu_variant_rv32i
|
|
);
|
|
|
|
tcpu_riscv64 = (
|
|
cpu_variant_riscv64_none,
|
|
cpu_variant_rv64imafdc,
|
|
cpu_variant_rv64imafd,
|
|
cpu_variant_rv64ima,
|
|
cpu_variant_rv64im,
|
|
cpu_variant_rv64i
|
|
);
|
|
|
|
tcpu_type = record
|
|
case tsystemcpu of
|
|
cpu_no: { 0 }
|
|
();
|
|
cpu_i386: { 1 }
|
|
(cpu_i386 : tcpu_i386;);
|
|
cpu_m68k: { 2 }
|
|
(cpu_m68k : tcpu_m68k;);
|
|
obsolete_cpu_alpha: { 3 }
|
|
();
|
|
cpu_powerpc: { 4 }
|
|
(cpu_powerpc : tcpu_powerpc;);
|
|
cpu_sparc: { 5 }
|
|
(cpu_sparc : tcpu_sparc;);
|
|
obsolete_cpu_vm: { 6 }
|
|
();
|
|
obsolete_cpu_ia64: { 7 }
|
|
();
|
|
cpu_x86_64: { 8 }
|
|
(cpu_x86_64 : tcpu_x86_64;);
|
|
cpu_mipseb: { 9 }
|
|
(cpu_mipseb : tcpu_mipseb;);
|
|
cpu_arm: { 10 }
|
|
(cpu_arm : tcpu_arm;);
|
|
cpu_powerpc64: { 11 }
|
|
(cpu_powerpc64 : tcpu_powerpc64;);
|
|
cpu_avr: { 12 }
|
|
(cpu_avr : tcpu_avr;);
|
|
cpu_mipsel: { 13 }
|
|
(cpu_mipsel : tcpu_mipsel;);
|
|
cpu_jvm: { 14 }
|
|
(cpu_jvm : tcpu_jvm;);
|
|
cpu_i8086: { 15 }
|
|
(cpu_i8086 : tcpu_i8086;);
|
|
cpu_aarch64: { 16 }
|
|
(cpu_aarch64 : tcpu_aarch64;);
|
|
cpu_wasm32: { 17 }
|
|
(cpu_wasm32 : tcpu_wasm32;);
|
|
cpu_sparc64: { 18 }
|
|
(cpu_sparc64 : tcpu_sparc64;);
|
|
cpu_riscv32: { 19 }
|
|
(cpu_riscv32 : tcpu_riscv32;);
|
|
cpu_riscv64: { 20 }
|
|
(cpu_riscv64 : tcpu_riscv64;);
|
|
end;
|
|
|
|
|
|
TPpuModuleDef = class(TPpuUnitDef)
|
|
ModuleFlags: tmoduleflags;
|
|
end;
|
|
|
|
type
|
|
t_ppu_endian = (ppu_unknown_endian, ppu_little_endian, ppu_big_endian );
|
|
tppudumpfile = class(tppufile)
|
|
internal_endian : t_ppu_endian;
|
|
protected
|
|
procedure RaiseAssertion(Code: Longint); override;
|
|
end;
|
|
|
|
var
|
|
ppufile : tppudumpfile;
|
|
ppuversion : dword;
|
|
space : string;
|
|
verbose : longint;
|
|
derefdata : pbyte;
|
|
derefdatalen : longint;
|
|
pout: TPpuOutput;
|
|
nostdout: boolean;
|
|
UnitList: TPpuContainerDef;
|
|
CurUnit: TPpuModuleDef;
|
|
SkipVersionCheck: boolean;
|
|
SymAnsiStr: boolean;
|
|
|
|
var
|
|
{ needed during tobjectdef parsing... }
|
|
current_defoptions : tdefoptions;
|
|
current_objectoptions : tobjectoptions;
|
|
current_symtable_options : tsymtableoptions;
|
|
|
|
{****************************************************************************
|
|
Helper Routines
|
|
****************************************************************************}
|
|
|
|
{****************************************************************************
|
|
Routine to read 80-bit reals
|
|
****************************************************************************
|
|
}
|
|
{$PUSH}
|
|
{$WARN 6018 OFF} { Turn off unreachable code warning }
|
|
{ On platforms with sizeof(ext) <> 10 the code below will cause an unreachable
|
|
code warning, which will cause compilation failures with -Sew (KB) }
|
|
type
|
|
TSplit80bitReal = packed record
|
|
case byte of
|
|
0: (bytes: Array[0..9] of byte);
|
|
1: (words: Array[0..4] of word);
|
|
end;
|
|
const
|
|
maxDigits = 17;
|
|
function Real80bitToStr(var e : TSplit80bitReal;var ext : extended) : string;
|
|
var
|
|
Temp : string;
|
|
new : TSplit80bitReal;
|
|
fraczero, expmaximal, sign, outside_double : boolean;
|
|
exp : smallint;
|
|
d : double;
|
|
i : longint;
|
|
e_qw, mantval : qword;
|
|
e_w : word;
|
|
begin
|
|
if sizeof(ext)=10 then
|
|
begin
|
|
ext:=pextended(@e)^;
|
|
str(ext,result);
|
|
exit;
|
|
end;
|
|
{ extended, format (MSB): 1 Sign bit, 15 bit exponent, 64 bit mantissa }
|
|
if (ppufile.internal_endian=ppu_big_endian) then
|
|
begin
|
|
e_w:=pword(@(e.bytes[0]))^;
|
|
e_qw:=unaligned(pqword(@(e.bytes[2]))^);
|
|
end
|
|
else
|
|
begin
|
|
e_w:=pword(@(e.bytes[8]))^;
|
|
e_qw:=pqword(@(e.bytes[0]))^;
|
|
end;
|
|
if ppufile.change_endian then
|
|
begin
|
|
e_w:=swapendian(e_w);
|
|
e_qw:=swapendian(e_qw);
|
|
end;
|
|
sign := (e_w and $8000) <> 0;
|
|
expMaximal := (e_w and $7fff) = 32767;
|
|
exp:=(e_w and $7fff) - 16383 - 63;
|
|
fraczero := ((e_qw and qword($7fffffffffffffff)) = 0);
|
|
mantval:=e_qw;
|
|
if expMaximal then
|
|
if fraczero then
|
|
if sign then
|
|
temp := '-Inf'
|
|
else temp := '+Inf'
|
|
else temp := 'Nan'
|
|
else
|
|
begin
|
|
d:=double(mantval);
|
|
if sign then
|
|
d:=-d;
|
|
outside_double:=false;
|
|
Try
|
|
if exp > 0 then
|
|
begin
|
|
for i:=1 to exp do
|
|
d:=d *2.0;
|
|
end
|
|
else if exp < 0 then
|
|
begin
|
|
for i:=1 to -exp do
|
|
d:=d /2.0;
|
|
end;
|
|
Except
|
|
outside_double:=true;
|
|
end;
|
|
if (mantval<>0) and (d=0.0) then
|
|
outside_double:=true;
|
|
if outside_double then
|
|
begin
|
|
Temp:='Extended value outside double bound';
|
|
ext:=0.0;
|
|
end
|
|
else
|
|
begin
|
|
ext:=d;
|
|
system.str(d,temp);
|
|
end;
|
|
end;
|
|
temp:=temp+' w=$'+hexstr(e_w,4)+',qw=$'+hexstr(e_qw,16);
|
|
result:=temp;
|
|
end;
|
|
{$POP}
|
|
|
|
const has_errors : boolean = false;
|
|
has_warnings : boolean = false;
|
|
has_more_infos : boolean = false;
|
|
|
|
procedure SetHasErrors;
|
|
begin
|
|
has_errors:=true;
|
|
end;
|
|
|
|
Procedure WriteError(const S : string);
|
|
Begin
|
|
system.Writeln(StdErr, S);
|
|
SetHasErrors;
|
|
End;
|
|
|
|
procedure StrAppend(var st : string; const st2 : string);
|
|
begin
|
|
st:=st+st2;
|
|
end;
|
|
|
|
procedure tppudumpfile.RaiseAssertion(Code: Longint);
|
|
begin
|
|
WriteError('Internal Error ' + ToStr(Code));
|
|
inherited RaiseAssertion(Code);
|
|
end;
|
|
|
|
Procedure WriteWarning(const S : string);
|
|
var
|
|
ss: string;
|
|
Begin
|
|
ss:='!! Warning: ' + S;
|
|
if nostdout then
|
|
system.Writeln(StdErr, ss)
|
|
else
|
|
system.Writeln(ss);
|
|
has_warnings:=true;
|
|
End;
|
|
|
|
procedure Write(const s: string);
|
|
begin
|
|
if nostdout then exit;
|
|
system.write(s);
|
|
end;
|
|
|
|
procedure Write(const params: array of const);
|
|
var
|
|
i: integer;
|
|
{ Last vtType define in rtl/inc/objpash.inc }
|
|
const
|
|
max_vttype = vtUnicodeString;
|
|
begin
|
|
if nostdout then exit;
|
|
for i:=Low(params) to High(params) do
|
|
{ All vtType in
|
|
vtInteger = 0;
|
|
vtBoolean = 1;
|
|
vtChar = 2;
|
|
vtExtended = 3;
|
|
vtString = 4;
|
|
vtPointer = 5;
|
|
vtPChar = 6;
|
|
vtObject = 7;
|
|
vtClass = 8;
|
|
vtWideChar = 9;
|
|
vtPWideChar = 10;
|
|
vtAnsiString32 = 11; called vtAnsiString in objpas unit
|
|
vtCurrency = 12;
|
|
vtVariant = 13;
|
|
vtInterface = 14;
|
|
vtWideString = 15;
|
|
vtInt64 = 16;
|
|
vtQWord = 17;
|
|
vtUnicodeString = 18;
|
|
// vtAnsiString16 = 19; not yet used
|
|
// vtAnsiString64 = 20; not yet used
|
|
}
|
|
with TVarRec(params[i]) do
|
|
case VType of
|
|
vtInteger: system.write(VInteger);
|
|
vtBoolean: system.write(VBoolean);
|
|
vtChar: system.write(VChar);
|
|
vtExtended: system.write(VExtended^);
|
|
vtString: system.write(VString^);
|
|
vtPointer:
|
|
begin
|
|
{ Not sure the display will be correct
|
|
if sizeof pointer is not native }
|
|
WriteWarning('Pointer constant');
|
|
end;
|
|
vtPChar: system.write(VPChar);
|
|
vtObject:
|
|
begin
|
|
{ Not sure the display will be correct
|
|
if sizeof pointer is not native }
|
|
WriteWarning('Object constant');
|
|
end;
|
|
vtClass:
|
|
begin
|
|
{ Not sure the display will be correct
|
|
if sizeof pointer is not native }
|
|
WriteWarning('Class constant');
|
|
end;
|
|
vtWideChar: system.write(VWideChar);
|
|
vtPWideChar:
|
|
begin
|
|
WriteWarning('PWideChar constant');
|
|
end;
|
|
vtAnsiString: system.write(ansistring(VAnsiString));
|
|
vtCurrency : system.write(VCurrency^);
|
|
vtVariant :
|
|
begin
|
|
{ Not sure the display will be correct
|
|
if sizeof pointer is not native }
|
|
WriteWarning('Variant constant');
|
|
end;
|
|
vtInterface :
|
|
begin
|
|
{ Not sure the display will be correct
|
|
if sizeof pointer is not native }
|
|
WriteWarning('Interface constant');
|
|
end;
|
|
vtWideString : system.write(widestring(VWideString));
|
|
vtInt64: system.write(VInt64^);
|
|
vtQWord: system.write(VQWord^);
|
|
vtUnicodeString : system.write(unicodestring(VUnicodeString));
|
|
else
|
|
begin
|
|
system.writeln;
|
|
system.writeln('Unsupported var type: ', VType);
|
|
Halt(10);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure Writeln(const s: string = '');
|
|
begin
|
|
if nostdout then exit;
|
|
system.writeln(s);
|
|
end;
|
|
|
|
procedure Writeln(const params: array of const);
|
|
begin
|
|
if nostdout then exit;
|
|
Write(params);
|
|
system.writeln;
|
|
end;
|
|
|
|
Procedure HasMoreInfos;
|
|
begin
|
|
Writeln('!! Entry has more information stored');
|
|
has_more_infos:=true;
|
|
end;
|
|
|
|
function Unknown(const st : string; val :longint) : string;
|
|
Begin
|
|
Unknown:='<!! Unknown'+st+' value '+tostr(val)+'>';
|
|
SetHasErrors;
|
|
end;
|
|
|
|
function ToStr(w:longint):String;
|
|
begin
|
|
Str(w,ToStr);
|
|
end;
|
|
|
|
Function Target2Str(w:longint):string;
|
|
begin
|
|
if w<=ord(high(tsystem)) then
|
|
Target2Str:=Targets[tsystem(w)]
|
|
else
|
|
Target2Str:=Unknown('target',w);
|
|
end;
|
|
|
|
|
|
Function Cpu2Str(w:longint):string;
|
|
begin
|
|
if w<=ord(high(tsystemcpu)) then
|
|
begin
|
|
cpu:=tsystemcpu(w);
|
|
Cpu2Str:=CpuTxt[cpu];
|
|
end
|
|
else
|
|
Cpu2Str:=Unknown('cpu',w);
|
|
end;
|
|
|
|
|
|
Function Varspez2Str(w:longint):string;
|
|
const
|
|
{ in symconst unit
|
|
tvarspez = (vs_value,vs_const,vs_var,vs_out,vs_constref); }
|
|
varspezstr : array[tvarspez] of string[8]=('Value','Const','Var','Out','ConstRef','Final');
|
|
begin
|
|
if w<=ord(high(varspezstr)) then
|
|
Varspez2Str:=varspezstr[tvarspez(w)]
|
|
else
|
|
Varspez2Str:=Unknown('varspez',w);
|
|
end;
|
|
|
|
Function VarRegable2Str(w:longint):string;
|
|
{ tvarregable type is defined in symconst unit }
|
|
const
|
|
varregableStr : array[tvarregable] of string[6]=('None','IntReg','FPUReg','MMReg','Addr');
|
|
begin
|
|
if w<=ord(high(varregablestr)) then
|
|
Varregable2Str:=varregablestr[tvarregable(w)]
|
|
else
|
|
Varregable2Str:=Unknown('regable',w);
|
|
end;
|
|
|
|
|
|
Function Visibility2Str(w:longint):string;
|
|
const
|
|
{ tvisibility type is defined in symconst unit }
|
|
|
|
visibilityName : array[tvisibility] of string[16] = (
|
|
'hidden','strict private','private','strict protected','protected',
|
|
'public','published','<none>'
|
|
);
|
|
begin
|
|
if w<=ord(high(visibilityName)) then
|
|
result:=visibilityName[tvisibility(w)]
|
|
else
|
|
result:=Unknown('visibility',w);
|
|
end;
|
|
|
|
|
|
Function IntfEntryType2Str(w:longint):string;
|
|
const
|
|
{ tinterfaceentrytype type is defined in symconst unit }
|
|
|
|
Name : array[tinterfaceentrytype] of string = (
|
|
'standard','virtual method result','static method result','field value','virtual method class',
|
|
'static method class','field value class'
|
|
);
|
|
begin
|
|
if w<=ord(high(Name)) then
|
|
result:=Name[tinterfaceentrytype(w)]
|
|
else
|
|
result:=Unknown('entry type',w);
|
|
end;
|
|
|
|
|
|
function PPUFlags2Str(flags:dword):string;
|
|
type
|
|
tflagopt=record
|
|
mask : dword;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
flagopts=8;
|
|
mask_big_endian = $4;
|
|
mask_little_endian = $1000;
|
|
flagopt : array[1..flagopts] of tflagopt=(
|
|
(mask: $4 ;str:'big_endian'),
|
|
// (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: $400 ;str:'no_link'),
|
|
(mask: $1000 ;str:'little_endian'),
|
|
(mask: $8000 ;str:'fpu_emulation_on')
|
|
);
|
|
var
|
|
i : longint;
|
|
ntflags : dword;
|
|
first : boolean;
|
|
s : string;
|
|
begin
|
|
s:='';
|
|
ntflags:=flags;
|
|
ppufile.internal_endian:=ppu_unknown_endian;
|
|
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;
|
|
if flagopt[i].mask=mask_big_endian then
|
|
begin
|
|
if (ppufile.internal_endian<>ppu_unknown_endian) then
|
|
begin
|
|
s:=s+' endianess explicitly set twice';
|
|
SetHasErrors;
|
|
end;
|
|
ppufile.internal_endian:=ppu_big_endian;
|
|
end;
|
|
if flagopt[i].mask=mask_little_endian then
|
|
begin
|
|
if (ppufile.internal_endian<>ppu_unknown_endian) then
|
|
begin
|
|
s:=s+' endianess explicitly set twice';
|
|
SetHasErrors;
|
|
end;
|
|
ppufile.internal_endian:=ppu_little_endian;
|
|
end;
|
|
ntflags:=ntflags and (not flagopt[i].mask);
|
|
end;
|
|
end
|
|
else
|
|
s:='none';
|
|
if ntflags<>0 then
|
|
begin
|
|
s:=s+' unknown '+hexstr(ntflags,8);
|
|
SetHasErrors;
|
|
end;
|
|
if (ppufile.internal_endian=ppu_unknown_endian) then
|
|
begin
|
|
s:=s+' endianess not explicitly set';
|
|
SetHasErrors;
|
|
end;
|
|
PPUFlags2Str:=s;
|
|
end;
|
|
|
|
|
|
Function L0(l:longint):string;
|
|
{
|
|
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 : string;
|
|
begin
|
|
Str(l,s);
|
|
if l<10 then
|
|
s:='0'+s;
|
|
L0:=s;
|
|
end;
|
|
|
|
|
|
function filetimestring( 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 := 'Not Found';
|
|
SetHasErrors;
|
|
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;
|
|
|
|
|
|
{****************************************************************************
|
|
Read Routines
|
|
****************************************************************************}
|
|
|
|
function readsymstr(ppufile: tppufile): ansistring;
|
|
begin
|
|
if not(mf_symansistr in CurUnit.ModuleFlags) then
|
|
result:=ppufile.getstring
|
|
else
|
|
result:=ppufile.getansistring;
|
|
end;
|
|
|
|
function readmanagementoperatoroptions(const space : string;const name : string):tmanagementoperators;forward;
|
|
|
|
procedure readrecsymtableoptions;
|
|
var
|
|
usefieldalignment : shortint;
|
|
begin
|
|
if ppufile.readentry<>ibrecsymtableoptions then
|
|
begin
|
|
SetHasErrors;
|
|
exit;
|
|
end;
|
|
writeln([space,' recordalignment: ',shortint(ppufile.getbyte)]);
|
|
usefieldalignment:=shortint(ppufile.getbyte);
|
|
writeln([space,' usefieldalignment: ',usefieldalignment]);
|
|
writeln([space,' recordalignmin: ',shortint(ppufile.getbyte)]);
|
|
if (usefieldalignment=C_alignment) then
|
|
writeln([space,' fieldalignment: ',shortint(ppufile.getbyte)]);
|
|
readmanagementoperatoroptions(space,'Fields have MOPs');
|
|
end;
|
|
|
|
function readsymtableoptions(const s: string) : tsymtableoptions;
|
|
type
|
|
tsymtblopt=record
|
|
mask : tsymtableoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
symtblopts=ord(high(tsymtableoption)) + 1;
|
|
symtblopt : array[1..symtblopts] of tsymtblopt=(
|
|
(mask:sto_has_helper; str:'Has helper'),
|
|
(mask:sto_has_generic; str:'Has generic'),
|
|
(mask:sto_has_operator; str:'Has operator'),
|
|
(mask:sto_needs_init_final;str:'Needs init final table'),
|
|
(mask:sto_has_non_trivial_init;str:'Has non trivial init')
|
|
);
|
|
var
|
|
options : tsymtableoptions;
|
|
first : boolean;
|
|
i : integer;
|
|
begin
|
|
if ppufile.readentry<>ibsymtableoptions then
|
|
begin
|
|
SetHasErrors;
|
|
exit;
|
|
end;
|
|
ppufile.getset(tppuset1(options));
|
|
if space<>'' then
|
|
writeln([space,'------ ',s,' ------']);
|
|
write([space,'Symtable options: ']);
|
|
if options<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to symtblopts do
|
|
if (symtblopt[i].mask in options) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(symtblopt[i].str);
|
|
end;
|
|
end
|
|
else
|
|
write('none');
|
|
writeln;
|
|
readsymtableoptions:=options;
|
|
end;
|
|
|
|
procedure readdefinitions(const s:string; ParentDef: TPpuContainerDef); forward;
|
|
procedure readsymbols(const s:string; ParentDef: TPpuContainerDef = nil); forward;
|
|
|
|
procedure readsymtable(const s: string; ParentDef: TPpuContainerDef = nil);
|
|
var
|
|
stored_symtable_options : tsymtableoptions;
|
|
begin
|
|
stored_symtable_options:=current_symtable_options;
|
|
current_symtable_options:=readsymtableoptions(s);
|
|
readdefinitions(s, ParentDef);
|
|
readsymbols(s, ParentDef);
|
|
current_symtable_options:=stored_symtable_options;
|
|
end;
|
|
|
|
procedure readrecordsymtable(const s: string; ParentDef: TPpuContainerDef = nil);
|
|
begin
|
|
readrecsymtableoptions;
|
|
readsymtable(s, ParentDef);
|
|
end;
|
|
|
|
Procedure ReadLinkContainer(const prefix:string);
|
|
{
|
|
Read a serie of strings and write to the screen starting every line
|
|
with prefix
|
|
}
|
|
function maskstr(m:longint):string;
|
|
{ link options are in globtype unit
|
|
const
|
|
link_none = $0;
|
|
link_always = $1;
|
|
link_static = $2;
|
|
link_smart = $4;
|
|
link_shared = $8; }
|
|
var
|
|
s : string;
|
|
begin
|
|
s:='';
|
|
if (m and link_always)<>0 then
|
|
s:=s+'always ';
|
|
if (m and link_static)<>0 then
|
|
s:=s+'static ';
|
|
if (m and link_smart)<>0 then
|
|
s:=s+'smart ';
|
|
if (m and link_shared)<>0 then
|
|
s:=s+'shared ';
|
|
maskstr:=s;
|
|
end;
|
|
|
|
var
|
|
s : string;
|
|
m : longint;
|
|
begin
|
|
while not ppufile.endofentry do
|
|
begin
|
|
s:=ppufile.getstring;
|
|
m:=ppufile.getlongint;
|
|
WriteLn([prefix,s,' (',maskstr(m),')']);
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure ReadContainer(const prefix:string);
|
|
{
|
|
Read a series of strings and write to the screen starting every line
|
|
with prefix
|
|
}
|
|
begin
|
|
while not ppufile.endofentry do
|
|
WriteLn([prefix,ppufile.getstring]);
|
|
end;
|
|
|
|
|
|
procedure ReadLoadUnit;
|
|
var
|
|
ucrc,uintfcrc, indcrc : cardinal;
|
|
un: TPpuUnitDef;
|
|
begin
|
|
while not ppufile.EndOfEntry do
|
|
begin
|
|
un:=TPpuUnitDef.Create(CurUnit.UsedUnits);
|
|
un.Name:=ppufile.getstring;
|
|
write(['Uses unit: ',un.Name]);
|
|
ucrc:=cardinal(ppufile.getlongint);
|
|
uintfcrc:=cardinal(ppufile.getlongint);
|
|
indcrc:=cardinal(ppufile.getlongint);
|
|
writeln([' (Crc: ',hexstr(ucrc,8),', IntfcCrc: ',hexstr(uintfcrc,8),', IndCrc: ',hexstr(indcrc,8),')']);
|
|
un.Crc:=ucrc;
|
|
un.IntfCrc:=uintfcrc;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure ReadDerefmap;
|
|
var
|
|
i,mapsize : longint;
|
|
s: string;
|
|
begin
|
|
mapsize:=ppufile.getlongint;
|
|
writeln(['DerefMapsize: ',mapsize]);
|
|
SetLength(CurUnit.RefUnits, mapsize);
|
|
for i:=0 to mapsize-1 do
|
|
begin
|
|
s:=ppufile.getstring;
|
|
writeln(['DerefMap[',i,'] = ',s]);
|
|
CurUnit.RefUnits[i]:=LowerCase(s);
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure ReadImportSymbols;
|
|
var
|
|
extlibname : string;
|
|
j,
|
|
extsymcnt : longint;
|
|
extsymname : string;
|
|
extsymmangledname : string;
|
|
extsymordnr : longint;
|
|
extsymisvar : boolean;
|
|
begin
|
|
while not ppufile.endofentry do
|
|
begin
|
|
extlibname:=ppufile.getstring;
|
|
extsymcnt:=ppufile.getlongint;
|
|
writeln(['External Library: ',extlibname,' (',extsymcnt,' imports)']);
|
|
for j:=0 to extsymcnt-1 do
|
|
begin
|
|
extsymname:=ppufile.getstring;
|
|
extsymmangledname:=ppufile.getstring;
|
|
extsymordnr:=ppufile.getlongint;
|
|
extsymisvar:=ppufile.getbyte<>0;
|
|
writeln([' ',extsymname,' as ',extsymmangledname,
|
|
'(OrdNr: ',extsymordnr,' IsVar: ',extsymisvar,')']);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure ReadDerefdata;
|
|
begin
|
|
derefdatalen:=ppufile.entrysize;
|
|
if derefdatalen=0 then
|
|
begin
|
|
Writeln(['No Derefdata length=0']);
|
|
derefdata:=nil;
|
|
exit;
|
|
end;
|
|
Writeln(['Derefdata length: ',derefdatalen]);
|
|
derefdata:=allocmem(derefdatalen);
|
|
ppufile.getdata(derefdata^,derefdatalen);
|
|
end;
|
|
|
|
Procedure FreeDerefdata;
|
|
begin
|
|
if assigned(derefdata) then
|
|
begin
|
|
FreeMem(derefdata);
|
|
derefdata:=nil;
|
|
derefdatalen:=0;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure ReadWpoFileInfo;
|
|
begin
|
|
Writeln(['Compiled with input whole-program optimisation from ',ppufile.getstring,' ',filetimestring(ppufile.getlongint)]);
|
|
end;
|
|
|
|
|
|
Procedure ReadAsmSymbols;
|
|
const
|
|
unitasmlisttype: array[tunitasmlisttype] of string[6]=(
|
|
'PUBLIC',
|
|
'EXTERN'
|
|
);
|
|
type
|
|
{ Copied from aasmbase.pas }
|
|
TAsmsymbind=(
|
|
AB_NONE,AB_EXTERNAL,AB_COMMON,AB_LOCAL,AB_GLOBAL,AB_WEAK_EXTERNAL,
|
|
{ global in the current program/library, but not visible outside it }
|
|
AB_PRIVATE_EXTERN,AB_LAZY,AB_IMPORT,
|
|
{ a symbol that's internal to the compiler and used as a temp }
|
|
AB_TEMP,
|
|
{ a global symbol that points to another global symbol and is only used
|
|
to allow indirect loading in case of packages and indirect imports }
|
|
AB_INDIRECT,AB_EXTERNAL_INDIRECT,
|
|
AB_WEAK);
|
|
|
|
TAsmsymtype=(
|
|
AT_NONE,AT_FUNCTION,AT_DATA,AT_SECTION,AT_LABEL,
|
|
{
|
|
the address of this code label is taken somewhere in the code
|
|
so it must be taken care of it when creating pic
|
|
}
|
|
AT_ADDR,
|
|
{ Label for debug or other non-program information }
|
|
AT_METADATA,
|
|
{ label for data that must always be accessed indirectly, because it
|
|
is handled explcitely in the system unit or (e.g. RTTI and threadvar
|
|
tables) -- never seen in an assembler/assembler writer, always
|
|
changed to AT_DATA }
|
|
AT_DATA_FORCEINDIRECT,
|
|
{ don't generate an implicit indirect symbol as that might be provided
|
|
by other means (e.g. the typed const builder) to ensure a correct
|
|
section name }
|
|
AT_DATA_NOINDIRECT,
|
|
{ Thread-local symbol (ELF targets) }
|
|
AT_TLS,
|
|
{ GNU indirect function (ELF targets) }
|
|
AT_GNU_IFUNC,
|
|
{ WebAssembly global variable }
|
|
AT_WASM_GLOBAL,
|
|
{ WebAssembly exception tag (used as a parameter for the 'throw' and
|
|
'catch' instructions) }
|
|
AT_WASM_EXCEPTION_TAG
|
|
);
|
|
|
|
var
|
|
s,
|
|
bindstr,
|
|
typestr : string;
|
|
i : longint;
|
|
t: tunitasmlisttype;
|
|
begin
|
|
writeln([space,'Assembler Symbols']);
|
|
writeln([space,'-----------------']);
|
|
t:=tunitasmlisttype(ppufile.getbyte);
|
|
if (t>=Low(tunitasmlisttype)) and (t<=High(tunitasmlisttype)) then
|
|
typestr:=unitasmlisttype[t]
|
|
else
|
|
typestr:='UNKNOWN';
|
|
writeln([space,'Type: ',typestr]);
|
|
writeln([space,'Count: ',ppufile.getlongint]);
|
|
i:=0;
|
|
while (not ppufile.endofentry) and (not ppufile.error) do
|
|
begin
|
|
s:=ppufile.getstring;
|
|
case tasmsymbind(ppufile.getbyte) of
|
|
AB_EXTERNAL :
|
|
bindstr:='External';
|
|
AB_COMMON :
|
|
bindstr:='Common';
|
|
AB_LOCAL :
|
|
bindstr:='Local';
|
|
AB_GLOBAL :
|
|
bindstr:='Global';
|
|
AB_WEAK_EXTERNAL :
|
|
bindstr:='Weak external';
|
|
AB_PRIVATE_EXTERN :
|
|
bindstr:='Private extern';
|
|
AB_LAZY :
|
|
bindstr:='Lazy';
|
|
AB_IMPORT :
|
|
bindstr:='Import';
|
|
AB_TEMP :
|
|
bindstr:='Temp';
|
|
AB_INDIRECT :
|
|
bindstr:='Indirect';
|
|
AB_EXTERNAL_INDIRECT :
|
|
bindstr:='Indirect external';
|
|
AB_WEAK:
|
|
bindstr:='Weak';
|
|
else
|
|
begin
|
|
bindstr:='<Error !!>';
|
|
SetHasErrors;
|
|
end;
|
|
end;
|
|
case tasmsymtype(ppufile.getbyte) of
|
|
AT_FUNCTION :
|
|
typestr:='Function';
|
|
AT_DATA :
|
|
typestr:='Data';
|
|
AT_SECTION :
|
|
typestr:='Section';
|
|
AT_LABEL :
|
|
typestr:='Label';
|
|
AT_ADDR :
|
|
typestr:='Label (with address taken)';
|
|
AT_METADATA :
|
|
typestr:='Metadata';
|
|
{ this shouldn't appear in a PPU }
|
|
AT_DATA_FORCEINDIRECT :
|
|
typestr:='Data (ForceIndirect)';
|
|
{ this shouldn't appear in a PPU }
|
|
AT_DATA_NOINDIRECT:
|
|
typestr:='Data (NoIndirect)';
|
|
AT_TLS :
|
|
typestr:='TLS';
|
|
AT_GNU_IFUNC :
|
|
typestr:='GNU IFUNC';
|
|
AT_WASM_GLOBAL:
|
|
typestr:='WebAssembly global variable';
|
|
AT_WASM_EXCEPTION_TAG:
|
|
typestr:='WebAssembly exception tag';
|
|
else
|
|
begin
|
|
typestr:='<Error !!>';
|
|
SetHasErrors;
|
|
end;
|
|
end;
|
|
Writeln([space,' ',i,' : ',s,' [',bindstr,',',typestr,']']);
|
|
inc(i);
|
|
end;
|
|
writeln([space]);
|
|
end;
|
|
|
|
function getexprint:Tconstexprint;
|
|
|
|
begin
|
|
getexprint.overflow:=false;
|
|
getexprint.signed:=ppufile.getboolean;
|
|
getexprint.svalue:=ppufile.getint64;
|
|
end;
|
|
|
|
Procedure ReadPosInfo(Def: TPpuDef = nil);
|
|
var
|
|
info : byte;
|
|
fileindex,line,column : longint;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
fileindex:=0;
|
|
line:=0;
|
|
column:=0;
|
|
{
|
|
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:=getbyte;
|
|
case (info and $03) of
|
|
0 : fileindex:=getbyte;
|
|
1 : fileindex:=getword;
|
|
2 : fileindex:=(getbyte shl 16) or getword;
|
|
3 : fileindex:=getlongint;
|
|
end;
|
|
case ((info shr 2) and $03) of
|
|
0 : line:=getbyte;
|
|
1 : line:=getword;
|
|
2 : line:=(getbyte shl 16) or getword;
|
|
3 : line:=getlongint;
|
|
end;
|
|
case ((info shr 4) and $03) of
|
|
0 : column:=getbyte;
|
|
1 : column:=getword;
|
|
2 : column:=(getbyte shl 16) or getword;
|
|
3 : column:=getlongint;
|
|
end;
|
|
Writeln([fileindex,' (',line,',',column,')']);
|
|
if Def <> nil then
|
|
begin
|
|
Def.FilePos.FileIndex:=fileindex;
|
|
Def.FilePos.Line:=line;
|
|
Def.FilePos.Col:=column;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure readderef(const derefspace: string; Ref: TPpuRef = nil);
|
|
var
|
|
b : tdereftype;
|
|
first : boolean;
|
|
idx : longint;
|
|
i,n : byte;
|
|
pdata : pbyte;
|
|
begin
|
|
if not assigned(derefdata) then
|
|
exit;
|
|
first:=true;
|
|
idx:=ppufile.getlongint;
|
|
if idx = -1 then
|
|
begin
|
|
writeln('Nil');
|
|
exit;
|
|
end;
|
|
if (idx>derefdatalen) then
|
|
begin
|
|
WriteError('!! Error: Deref idx '+IntToStr(idx)+' > '+IntToStr(derefdatalen));
|
|
exit;
|
|
end;
|
|
write([derefspace,'(',idx,') ']);
|
|
pdata:=@derefdata[idx];
|
|
i:=0;
|
|
n:=pdata[i];
|
|
inc(i);
|
|
if n<1 then
|
|
begin
|
|
WriteError('!! Error: Deref len < 1');
|
|
exit;
|
|
end;
|
|
while (i<=n) do
|
|
begin
|
|
if not first then
|
|
write(', ')
|
|
else
|
|
first:=false;
|
|
b:=tdereftype(pdata[i]);
|
|
inc(i);
|
|
case b of
|
|
deref_nil :
|
|
write('Nil');
|
|
deref_symid :
|
|
begin
|
|
idx:=BEtoN(unaligned(PInt32(@pdata[i{..i+3}])^));
|
|
inc(i,4);
|
|
write(['SymId ',idx]);
|
|
if Ref <> nil then
|
|
Ref.Id:=idx;
|
|
end;
|
|
deref_defid :
|
|
begin
|
|
idx:=BEtoN(unaligned(PInt32(@pdata[i{..i+3}])^));
|
|
inc(i,4);
|
|
write(['DefId ',idx]);
|
|
if Ref <> nil then
|
|
Ref.Id:=idx;
|
|
end;
|
|
deref_unit :
|
|
begin
|
|
idx:=BEtoN(unaligned(PUint16(@pdata[i{..i+1}])^));
|
|
inc(i,2);
|
|
write(['Unit ',idx]);
|
|
if Ref <> nil then
|
|
Ref.UnitIndex:=idx;
|
|
end;
|
|
else
|
|
begin
|
|
WriteError('!! unsupported dereftyp: '+IntToStr(ord(b)));
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
|
|
|
|
Procedure ReadUnitImportSyms;
|
|
var
|
|
c,i : longint;
|
|
begin
|
|
writeln([space,'Imported Symbols']);
|
|
writeln([space,'----------------']);
|
|
c:=ppufile.getlongint;
|
|
for i:=0 to c-1 do
|
|
readderef(space);
|
|
writeln([space]);
|
|
end;
|
|
|
|
|
|
procedure readpropaccesslist(const s:string; Ref: TPpuRef = nil);
|
|
{ type tsltype is in symconst unit }
|
|
const
|
|
slstr : array[tsltype] of string[12] = (
|
|
'',
|
|
'load',
|
|
'call',
|
|
'subscript',
|
|
'vec',
|
|
'typeconv',
|
|
'absolutetype'
|
|
);
|
|
var
|
|
sl : tsltype;
|
|
begin
|
|
readderef('',Ref);
|
|
repeat
|
|
sl:=tsltype(ppufile.getbyte);
|
|
if sl=sl_none then
|
|
break;
|
|
write([s,'(',slstr[sl],') ']);
|
|
case sl of
|
|
sl_none : ;
|
|
sl_call,
|
|
sl_load,
|
|
sl_subscript :
|
|
if (Ref <> nil) and (Ref.IsNull) then
|
|
begin
|
|
readderef('',Ref);
|
|
Ref.IsSymId:=True;
|
|
end
|
|
else
|
|
readderef('');
|
|
sl_absolutetype,
|
|
sl_typeconv :
|
|
readderef('');
|
|
sl_vec :
|
|
begin
|
|
writeln([ppufile.getlongint]);
|
|
readderef('');
|
|
end;
|
|
end;
|
|
until false;
|
|
end;
|
|
|
|
(*
|
|
talignmentinfo = packed record
|
|
procalign,
|
|
loopalign,
|
|
jumpalign,
|
|
constalignmin,
|
|
constalignmax,
|
|
varalignmin,
|
|
varalignmax,
|
|
localalignmin,
|
|
localalignmax,
|
|
recordalignmin,
|
|
recordalignmax,
|
|
maxCrecordalign : longint;
|
|
end;
|
|
|
|
|
|
tsettings = packed record
|
|
alignment : talignmentinfo;
|
|
globalswitches : tglobalswitches;
|
|
moduleswitches : tmoduleswitches;
|
|
localswitches : tlocalswitches;
|
|
modeswitches : tmodeswitches;
|
|
optimizerswitches : toptimizerswitches;
|
|
{ generate information necessary to perform these wpo's during a subsequent compilation }
|
|
genwpoptimizerswitches: twpoptimizerswitches;
|
|
{ perform these wpo's using information generated during a previous compilation }
|
|
dowpoptimizerswitches: twpoptimizerswitches;
|
|
debugswitches : tdebugswitches;
|
|
{ 0: old behaviour for sets <=256 elements
|
|
>0: round to this size }
|
|
setalloc,
|
|
packenum : shortint;
|
|
|
|
packrecords : shortint;
|
|
maxfpuregisters : shortint;
|
|
|
|
cputype,
|
|
optimizecputype : tcputype;
|
|
fputype : tfputype;
|
|
asmmode : tasmmode;
|
|
interfacetype : tinterfacetypes;
|
|
defproccall : tproccalloption;
|
|
sourcecodepage : tcodepagestring;
|
|
|
|
minfpconstprec : tfloattype;
|
|
|
|
disabledircache : boolean;
|
|
|
|
{ CPU targets with microcontroller support can add a controller specific unit }
|
|
controllertype : tcontrollertype;
|
|
{ WARNING: this pointer cannot be written as such in record token }
|
|
pmessage : pmessagestaterecord;
|
|
end;
|
|
|
|
*)
|
|
procedure readprocinfooptions(space : string);
|
|
(*
|
|
tprocinfoflag=(
|
|
{ procedure has at least one assembler block }
|
|
pi_has_assembler_block,
|
|
{ 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,
|
|
{ procedure has the implicit try..finally generated }
|
|
pi_has_implicit_finally,
|
|
{ procedure uses fpu}
|
|
pi_uses_fpu,
|
|
{ procedure uses GOT for PIC code }
|
|
pi_needs_got,
|
|
{ references var/proc/type/const in static symtable,
|
|
i.e. not allowed for inlining from other units }
|
|
pi_uses_static_symtable,
|
|
{ set if the procedure has to push parameters onto the stack }
|
|
pi_has_stackparameter,
|
|
{ set if the procedure has at least one label }
|
|
pi_has_label,
|
|
{ calls itself recursive }
|
|
pi_is_recursive,
|
|
{ stack frame optimization not possible (only on x86 probably) }
|
|
pi_needs_stackframe,
|
|
{ set if the procedure has at least one register saved on the stack }
|
|
pi_has_saved_regs,
|
|
{ dfa was generated for this proc }
|
|
pi_dfaavailable,
|
|
{ subroutine contains interprocedural used labels }
|
|
pi_has_interproclabel,
|
|
{ subroutine contains interprocedural gotos }
|
|
pi_has_global_goto
|
|
); *)
|
|
|
|
type
|
|
tprocinfoopt=record
|
|
mask : tprocinfoflag;
|
|
str : string[82];
|
|
end;
|
|
const
|
|
procinfoopts=ord(high(tprocinfoflag)) - ord(low(tprocinfoflag));
|
|
procinfoopt : array[0..procinfoopts] of tprocinfoopt=(
|
|
(mask:pi_has_assembler_block;
|
|
str:' has at least one assembler block'),
|
|
(mask:pi_do_call;
|
|
str:' does a call'),
|
|
(mask:pi_uses_exceptions;
|
|
str:' has a try statement = no register optimization '),
|
|
(mask:pi_is_assembler;
|
|
str:' is declared as @var(assembler), don''t optimize'),
|
|
(mask:pi_needs_implicit_finally;
|
|
str:' contains data which needs to be finalized '),
|
|
(mask:pi_has_implicit_finally;
|
|
str:' has the implicit try..finally generated '),
|
|
(mask:pi_uses_fpu;
|
|
str:' uses fpu'),
|
|
(mask:pi_needs_got;
|
|
str:' uses GOT for PIC code '),
|
|
(mask:pi_uses_static_symtable;
|
|
str:' references var/proc/type/const in static symtable'),
|
|
(mask:pi_has_stackparameter;
|
|
str:' set if the procedure has to push parameters onto the stack '),
|
|
(mask:pi_has_label;
|
|
str:' set if the procedure has at least one label '),
|
|
(mask:pi_is_recursive;
|
|
str:' calls itself recursive '),
|
|
(mask:pi_needs_stackframe;
|
|
str:' stack frame optimization not possible (only on x86 probably) '),
|
|
(mask:pi_has_saved_regs;
|
|
str:' set if the procedure has at least one register saved on the stack '),
|
|
(mask:pi_dfaavailable;
|
|
str:' dfa was generated for this proc '),
|
|
(mask:pi_has_interproclabel;
|
|
str:' subroutine contains interprocedural used labels '),
|
|
(mask:pi_has_unwind_info;
|
|
str:' unwinding info was generated for this proc '),
|
|
(mask:pi_has_global_goto;
|
|
str:' subroutine contains interprocedural goto '),
|
|
(mask:pi_has_inherited;
|
|
str:' subroutine contains inherited call '),
|
|
(mask:pi_has_nested_exit;
|
|
str:' subroutine contains a nested subroutine which calls the exit of the current one '),
|
|
(mask:pi_has_stack_allocs;
|
|
str:' allocates memory on stack, so stack may be unbalanced on exit '),
|
|
(mask:pi_estimatestacksize;
|
|
str:' stack size is estimated before subroutine is compiled '),
|
|
(mask:pi_calls_c_varargs;
|
|
str:' calls function with C-style varargs '),
|
|
(mask:pi_has_open_array_parameter;
|
|
str:' has open array parameter '),
|
|
(mask:pi_uses_threadvar;
|
|
str:' uses threadvars '),
|
|
(mask:pi_has_except_table_data;
|
|
str:' has except table data '),
|
|
(mask:pi_needs_tls;
|
|
str:' uses TLS data pointer '),
|
|
(mask:pi_uses_get_frame;
|
|
str:' uses get_frame'),
|
|
(mask:pi_uses_ymm;
|
|
str:' uses ymm register (x86 only)'),
|
|
(mask:pi_no_framepointer_needed;
|
|
str:' set if no frame pointer is needed, the rules when this applies is target specific'
|
|
)
|
|
);
|
|
var
|
|
procinfooptions : tprocinfoflags;
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset4(procinfooptions));
|
|
if procinfooptions<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=0 to procinfoopts do
|
|
if (procinfoopt[i].mask in procinfooptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(procinfoopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
|
|
procedure readsymoptions(space : string; Def: TPpuDef = nil);
|
|
type
|
|
tsymopt=record
|
|
mask : tsymoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
symopts=ord(high(tsymoption)) - ord(low(tsymoption));
|
|
{ sp_none = 0 corresponds to nothing }
|
|
symopt : array[1..symopts] of tsymopt=(
|
|
(mask:sp_static; str:'Static'),
|
|
(mask:sp_hint_deprecated; str:'Hint Deprecated'),
|
|
(mask:sp_hint_platform; str:'Hint Platform'),
|
|
(mask:sp_hint_library; str:'Hint Library'),
|
|
(mask:sp_hint_unimplemented; str:'Hint Unimplemented'),
|
|
(mask:sp_hint_experimental; str:'Hint Experimental'),
|
|
(mask:sp_has_overloaded; str:'Has overloaded'),
|
|
(mask:sp_internal; str:'Internal'),
|
|
(mask:sp_implicitrename; str:'Implicit Rename'),
|
|
(mask:sp_generic_para; str:'Generic Parameter'),
|
|
(mask:sp_has_deprecated_msg; str:'Has Deprecated Message'),
|
|
(mask:sp_generic_dummy; str:'Generic Dummy'),
|
|
(mask:sp_explicitrename; str:'Explicit Rename'),
|
|
(mask:sp_generic_const; str:'Generic Constant Parameter'),
|
|
(mask:sp_generic_unnamed_type;str:'Generic Unnamed Type')
|
|
);
|
|
var
|
|
symoptions : tsymoptions;
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset2(symoptions));
|
|
if symoptions<>[] then
|
|
begin
|
|
if Def <> nil then
|
|
begin
|
|
if sp_internal in symoptions then
|
|
Def.Visibility:=dvHidden;
|
|
if sp_generic_dummy in symoptions then
|
|
Def.GenericDummy:=true;
|
|
end;
|
|
first:=true;
|
|
for i:=1to symopts do
|
|
if (symopt[i].mask in symoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(symopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
if sp_has_deprecated_msg in symoptions then
|
|
writeln([space,'Deprecated : ', ppufile.getstring]);
|
|
end;
|
|
|
|
procedure readvisibility(Def: TPpuDef = nil);
|
|
var
|
|
i: byte;
|
|
begin
|
|
i:=ppufile.getbyte;
|
|
if Def <> nil then
|
|
case tvisibility(i) of
|
|
vis_public: Def.Visibility:=dvPublic;
|
|
vis_published: Def.Visibility:=dvPublished;
|
|
vis_protected, vis_strictprotected: Def.Visibility:=dvProtected;
|
|
else Def.Visibility:=dvPrivate;
|
|
end;
|
|
writeln(Visibility2Str(i));
|
|
end;
|
|
|
|
procedure readattrs(def: TPpuDef);
|
|
var
|
|
i,cnt,paras: longint;
|
|
begin
|
|
cnt:=ppufile.getlongint;
|
|
if cnt>0 then
|
|
begin
|
|
writeln([space,' Attributes : ']);
|
|
space:=' '+space;
|
|
if assigned(def) then
|
|
SetLength(def.Attrs,cnt);
|
|
for i:=0 to cnt-1 do
|
|
begin
|
|
writeln([space,'** Custom Attribute ',i,' **']);
|
|
write ([space,' Type symbol : ']);
|
|
if assigned(def) then
|
|
begin
|
|
def.Attrs[i].TypeSym:=TPpuRef.Create;
|
|
readderef('',def.Attrs[i].TypeSym);
|
|
end
|
|
else
|
|
readderef('');
|
|
write ([space,' Type constructor : ']);
|
|
if assigned(def) then
|
|
begin
|
|
def.Attrs[i].TypeConstr:=TPpuRef.Create;
|
|
readderef('',def.Attrs[i].TypeConstr);
|
|
end
|
|
else
|
|
readderef('');
|
|
paras:=ppufile.getlongint;
|
|
writeln([space,' Parameters : ',paras]);
|
|
if assigned(def) then
|
|
def.Attrs[i].ParaCount:=paras;
|
|
end;
|
|
delete(space,1,4);
|
|
end;
|
|
end;
|
|
|
|
procedure readnodetree; forward;
|
|
|
|
procedure readattrparas(def: TPpuDef);
|
|
var
|
|
attr,para: LongInt;
|
|
begin
|
|
if Length(def.Attrs) > 0 then
|
|
writeln([space,' Attr Paras : ']);
|
|
space:=' '+space;
|
|
for attr:=0 to High(def.Attrs) do
|
|
begin
|
|
writeln([space,'** Custom Attribute ',attr,' Arguments **']);
|
|
space:=' '+space;
|
|
for para:=0 to def.Attrs[attr].ParaCount-1 do
|
|
begin
|
|
readnodetree;
|
|
end;
|
|
delete(space,1,4);
|
|
end;
|
|
delete(space,1,4);
|
|
end;
|
|
|
|
procedure readdefsubentries(def: TPpuDef);
|
|
begin
|
|
space:=' '+space;
|
|
readattrparas(def);
|
|
delete(space,1,4);
|
|
end;
|
|
|
|
procedure readsymsubentries(def: TPpuDef);
|
|
begin
|
|
readattrparas(def);
|
|
end;
|
|
|
|
procedure readcommonsym(const s:string; Def: TPpuDef = nil);
|
|
var
|
|
i: integer;
|
|
n: ansistring;
|
|
begin
|
|
n:=readsymstr(ppufile);
|
|
if Def <> nil then
|
|
Def.Name:=n;
|
|
i:=ppufile.getlongint;
|
|
if Def <> nil then
|
|
Def.SetSymId(i);
|
|
writeln([space,'** Symbol Id ',i,' **']);
|
|
writeln([space,s,n]);
|
|
write ([space,' File Pos : ']);
|
|
readposinfo(Def);
|
|
write ([space,' Visibility : ']);
|
|
readvisibility(Def);
|
|
write ([space,' SymOptions : ']);
|
|
readsymoptions(space+' ',Def);
|
|
readattrs(Def);
|
|
end;
|
|
|
|
|
|
procedure readcgpara(const space:string);
|
|
{ this is originally in cgbase.pas }
|
|
type
|
|
TCGLoc=(LOC_INVALID, LOC_VOID, LOC_CONSTANT, LOC_JUMP, LOC_FLAGS,
|
|
LOC_REGISTER, LOC_CREGISTER, LOC_FPUREGISTER, LOC_CFPUREGISTER,
|
|
LOC_MMXREGISTER, LOC_CMMXREGISTER, LOC_MMREGISTER, LOC_CMMREGISTER,
|
|
LOC_SUBSETREG, LOC_CSUBSETREG, LOC_SUBSETREF, LOC_CSUBSETREF,
|
|
LOC_CREFERENCE, LOC_REFERENCE);
|
|
|
|
const
|
|
tcgloc2str : array[TCGLoc] of string[12] = (
|
|
'LOC_INVALID', 'LOC_VOID', 'LOC_CONST', 'LOC_JUMP', 'LOC_FLAGS',
|
|
'LOC_REG', 'LOC_CREG', 'LOC_FPUREG', 'LOC_CFPUREG',
|
|
'LOC_MMXREG', 'LOC_CMMXREG', 'LOC_MMREG', 'LOC_CMMREG',
|
|
'LOC_SSETREG', 'LOC_CSSETREG', 'LOC_SSETREF', 'LOC_CSSETREF',
|
|
'LOC_CREF', 'LOC_REF');
|
|
var
|
|
i: byte;
|
|
ii: longint;
|
|
np: byte;
|
|
loc: tcgloc;
|
|
begin
|
|
i:=ppufile.getbyte;
|
|
writeln([space,' Alignment : ',i]);
|
|
i:=ppufile.getbyte;
|
|
writeln([space,' Size : ',i]);
|
|
ii:=ppufile.getaint;
|
|
writeln([space,' IntSize : ',ii]);
|
|
readderef(space+' ');
|
|
np:=ppufile.getbyte;
|
|
writeln([space,' NumParaloc : ',np]);
|
|
while np > 0 do
|
|
begin
|
|
i:=ppufile.getbyte;
|
|
writeln([space,' Paraloc Size : ',i]);
|
|
loc:=tcgloc(ppufile.getbyte);
|
|
if loc > high(tcgloc) then
|
|
begin
|
|
WriteError('!! Location is out of range! '+IntToStr(ord(loc)));
|
|
loc:=LOC_INVALID;
|
|
end;
|
|
writeln([space,' Paraloc Loc : (',ord(loc),') ',tcgloc2str[loc]]);
|
|
case loc of
|
|
LOC_REFERENCE:
|
|
begin
|
|
writeln([space,' RegIndex : $',hexstr(ppufile.getdword,8)]);
|
|
writeln([space,' Offset : ',ppufile.getaint]);
|
|
end;
|
|
LOC_FPUREGISTER,
|
|
LOC_CFPUREGISTER,
|
|
LOC_MMREGISTER,
|
|
LOC_CMMREGISTER,
|
|
LOC_REGISTER,
|
|
LOC_CREGISTER :
|
|
begin
|
|
writeln([space,' ShiftVal : ',ppufile.getbyte]);
|
|
writeln([space,' Register : $',hexstr(ppufile.getdword,8)]);
|
|
end;
|
|
LOC_VOID:
|
|
begin end
|
|
else
|
|
WriteError('!! Invalid location error')
|
|
end;
|
|
dec(np);
|
|
end;
|
|
end;
|
|
|
|
procedure displaytokenbuffer(tokenbuf : pbyte;tokenbufsize : longint);
|
|
type
|
|
ptoken=^ttoken;
|
|
pmsgstate =^tmsgstate;
|
|
var
|
|
tbi : longint;
|
|
state : tmsgstate;
|
|
prev_settings, new_settings : Tsettings;
|
|
nb, msgvalue, mesgnb : longint;
|
|
|
|
|
|
function readtoken: ttoken;
|
|
var
|
|
b,b2 : byte;
|
|
begin
|
|
b:=tokenbuf[tbi];
|
|
inc(tbi);
|
|
if (b and $80)<>0 then
|
|
begin
|
|
b2:=tokenbuf[tbi];
|
|
inc(tbi);
|
|
result:=ttoken(((b and $7f) shl 8) or b2);
|
|
end
|
|
else
|
|
result:=ttoken(b);
|
|
end;
|
|
|
|
function gettokenbufdword : dword;
|
|
var
|
|
var32 : dword;
|
|
begin
|
|
var32:=unaligned(pdword(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(dword));
|
|
if ppufile.change_endian then
|
|
var32:=swapendian(var32);
|
|
result:=var32;
|
|
end;
|
|
|
|
function gettokenbufword : word;
|
|
var
|
|
var16 : word;
|
|
begin
|
|
var16:=unaligned(pword(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(word));
|
|
if ppufile.change_endian then
|
|
var16:=swapendian(var16);
|
|
result:=var16;
|
|
end;
|
|
|
|
function gettokenbuflongint : longint;
|
|
var
|
|
var32 : longint;
|
|
begin
|
|
var32:=unaligned(plongint(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(longint));
|
|
if ppufile.change_endian then
|
|
var32:=swapendian(var32);
|
|
result:=var32;
|
|
end;
|
|
|
|
function gettokenbufshortint : shortint;
|
|
var
|
|
var8 : shortint;
|
|
begin
|
|
var8:=pshortint(@tokenbuf[tbi])^;
|
|
inc(tbi,sizeof(shortint));
|
|
result:=var8;
|
|
end;
|
|
|
|
procedure tokenreadset(var b;size : longint);
|
|
var
|
|
i : longint;
|
|
begin
|
|
move(tokenbuf[tbi],b,size);
|
|
inc(tbi,size);
|
|
if ppufile.change_endian then
|
|
for i:=0 to size-1 do
|
|
Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
|
|
end;
|
|
|
|
function gettokenbufbyte : byte;
|
|
begin
|
|
result:=pbyte(@tokenbuf[tbi])^;
|
|
inc(tbi);
|
|
end;
|
|
|
|
function tokenreadenum(size : longint) : longword;
|
|
begin
|
|
if size=1 then
|
|
result:=gettokenbufbyte
|
|
else if size=2 then
|
|
result:=gettokenbufword
|
|
else if size=4 then
|
|
result:=gettokenbufdword;
|
|
end;
|
|
|
|
|
|
|
|
function gettokenbufsizeint : int64;
|
|
var
|
|
var64 : int64;
|
|
var32 : longint;
|
|
var16 : smallint;
|
|
|
|
begin
|
|
if CpuAddrBitSize[cpu]=64 then
|
|
begin
|
|
var64:=unaligned(pint64(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(int64));
|
|
if ppufile.change_endian then
|
|
var64:=swapendian(var64);
|
|
result:=var64;
|
|
end
|
|
else if CpuAddrBitSize[cpu]=32 then
|
|
begin
|
|
var32:=unaligned(plongint(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(longint));
|
|
if ppufile.change_endian then
|
|
var32:=swapendian(var32);
|
|
result:=var32;
|
|
end
|
|
else if CpuAddrBitSize[cpu]=16 then
|
|
begin
|
|
{ ASizeInt is still a longint, see globtype.pas unit }
|
|
var32:=unaligned(plongint(@tokenbuf[tbi])^);
|
|
inc(tbi,sizeof(longint));
|
|
if ppufile.change_endian then
|
|
var32:=swapendian(var32);
|
|
result:=var32;
|
|
end
|
|
else
|
|
begin
|
|
WriteError('Wrong CpuAddrBitSize');
|
|
result:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure tokenreadsettings(var asettings : tsettings; expected_size : asizeint);
|
|
|
|
{ This procedure
|
|
needs to be changed whenever
|
|
globals.tsettings type is changed,
|
|
the problem is that no error will appear
|
|
before tests with generics are tested. PM }
|
|
|
|
var
|
|
startpos, endpos : longword;
|
|
begin
|
|
{ WARNING all those fields need to be in the correct
|
|
order otherwise cross_endian PPU reading will fail }
|
|
startpos:=tbi;
|
|
with asettings do
|
|
begin
|
|
alignment.procalign:=gettokenbuflongint;
|
|
alignment.loopalign:=gettokenbuflongint;
|
|
alignment.jumpalign:=gettokenbuflongint;
|
|
alignment.jumpalignskipmax:=gettokenbuflongint;
|
|
alignment.coalescealign:=gettokenbuflongint;
|
|
alignment.coalescealignskipmax:=gettokenbuflongint;
|
|
alignment.constalignmin:=gettokenbuflongint;
|
|
alignment.constalignmax:=gettokenbuflongint;
|
|
alignment.varalignmin:=gettokenbuflongint;
|
|
alignment.varalignmax:=gettokenbuflongint;
|
|
alignment.localalignmin:=gettokenbuflongint;
|
|
alignment.localalignmax:=gettokenbuflongint;
|
|
alignment.recordalignmin:=gettokenbuflongint;
|
|
alignment.recordalignmax:=gettokenbuflongint;
|
|
alignment.maxCrecordalign:=gettokenbuflongint;
|
|
tokenreadset(globalswitches,sizeof(globalswitches));
|
|
tokenreadset(targetswitches,sizeof(targetswitches));
|
|
tokenreadset(moduleswitches,sizeof(moduleswitches));
|
|
tokenreadset(localswitches,sizeof(localswitches));
|
|
tokenreadset(modeswitches,sizeof(modeswitches));
|
|
tokenreadset(optimizerswitches,sizeof(optimizerswitches));
|
|
tokenreadset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches));
|
|
tokenreadset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches));
|
|
tokenreadset(debugswitches,sizeof(debugswitches));
|
|
{ 0: old behaviour for sets <=256 elements
|
|
>0: round to this size }
|
|
setalloc:=gettokenbufshortint;
|
|
packenum:=gettokenbufshortint;
|
|
|
|
packrecords:=gettokenbufshortint;
|
|
maxfpuregisters:=gettokenbufshortint;
|
|
|
|
cputype:=tcputype(tokenreadenum(sizeof(tcputype)));
|
|
optimizecputype:=tcputype(tokenreadenum(sizeof(tcputype)));
|
|
fputype:=tfputype(tokenreadenum(sizeof(tfputype)));
|
|
asmmode:=tasmmode(tokenreadenum(sizeof(tasmmode)));
|
|
interfacetype:=tinterfacetypes(tokenreadenum(sizeof(tinterfacetypes)));
|
|
defproccall:=tproccalloption(tokenreadenum(sizeof(tproccalloption)));
|
|
{ tstringencoding is word type,
|
|
thus this should be OK here }
|
|
sourcecodepage:=tstringEncoding(gettokenbufword);
|
|
|
|
minfpconstprec:=tfloattype(tokenreadenum(sizeof(tfloattype)));
|
|
|
|
disabledircache:=boolean(gettokenbufbyte);
|
|
|
|
tlsmodel:=ttlsmodel(tokenreadenum(sizeof(ttlsmodel)));
|
|
{ TH: Since the field was conditional originally, it was not stored in PPUs. }
|
|
{ While adding ControllerSupport constant, I decided not to store ct_none }
|
|
{ on targets not supporting controllers, but this might be changed here and }
|
|
{ in tokenwritesettings in the future to unify the PPU structure and handling }
|
|
{ of this field in the compiler. }
|
|
{$PUSH}
|
|
{$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *)
|
|
if CpuHasController[cpu] then
|
|
controllertype:=tcontrollertype(tokenreadenum(sizeof(tcontrollertype)))
|
|
else
|
|
ControllerType:=ct_none;
|
|
{$POP}
|
|
endpos:=tbi;
|
|
if endpos-startpos<>expected_size then
|
|
Writeln(['Wrong size of Settings read-in: ',expected_size,' expected, but got ',endpos-startpos]);
|
|
end;
|
|
end;
|
|
procedure dump_new_settings;
|
|
(* tsettings = record
|
|
alignment : talignmentinfo;
|
|
globalswitches : tglobalswitches;
|
|
targetswitches : ttargetswitches;
|
|
moduleswitches : tmoduleswitches;
|
|
localswitches : tlocalswitches;
|
|
modeswitches : tmodeswitches;
|
|
optimizerswitches : toptimizerswitches;
|
|
{ generate information necessary to perform these wpo's during a subsequent compilation }
|
|
genwpoptimizerswitches: twpoptimizerswitches;
|
|
{ perform these wpo's using information generated during a previous compilation }
|
|
dowpoptimizerswitches: twpoptimizerswitches;
|
|
debugswitches : tdebugswitches;
|
|
{ 0: old behaviour for sets <=256 elements
|
|
>0: round to this size }
|
|
setalloc,
|
|
packenum : shortint;
|
|
|
|
packrecords : shortint;
|
|
maxfpuregisters : shortint;
|
|
|
|
cputype,
|
|
optimizecputype,
|
|
asmcputype : tcputype;
|
|
fputype : tfputype;
|
|
asmmode : tasmmode;
|
|
interfacetype : tinterfacetypes;
|
|
defproccall : tproccalloption;
|
|
sourcecodepage : tstringencoding;
|
|
|
|
minfpconstprec : tfloattype;
|
|
|
|
disabledircache : boolean;
|
|
|
|
tlsmodel : ttlsmodel;
|
|
|
|
{$if defined(i8086)}
|
|
x86memorymodel : tx86memorymodel;
|
|
{$endif defined(i8086)}
|
|
|
|
{$if defined(ARM)}
|
|
instructionset : tinstructionset;
|
|
{$endif defined(ARM)}
|
|
|
|
{$if defined(LLVM) and not defined(GENERIC_CPU)}
|
|
llvmversion: tllvmversion;
|
|
{$endif defined(LLVM) and not defined(GENERIC_CPU)}
|
|
|
|
{ CPU targets with microcontroller support can add a controller specific unit }
|
|
controllertype : tcontrollertype;
|
|
|
|
{ WARNING: this pointer cannot be written as such in record token }
|
|
pmessage : pmessagestaterecord;
|
|
end; *)
|
|
|
|
const
|
|
targetswitchname : array[ttargetswitch] of string[37] =
|
|
{ global target-specific switches }
|
|
('Target None', {ts_none}
|
|
{ generate code that results in smaller TOCs than normal (AIX) }
|
|
'Small TOC', {ts_small_toc}
|
|
{ for the JVM target: generate integer array initializations via string
|
|
constants in order to reduce the generated code size (Java routines
|
|
are limited to 64kb of bytecode) }
|
|
'JVM compact int array init', {ts_compact_int_array_init}
|
|
{ for the JVM target: intialize enum fields in constructors with the
|
|
enum class instance corresponding to ordinal value 0 (not done by
|
|
default because this initialization can only be performed after the
|
|
inherited constructors have run, and if they call a virtual method
|
|
of the current class, then this virtual method may already have
|
|
initialized that field with another value and the constructor
|
|
initialization will result in data loss }
|
|
'JVM enum field init', {ts_jvm_enum_field_init}
|
|
{ when automatically generating getters/setters for properties, use
|
|
these strings as prefixes for the generated getters/setter names }
|
|
'Auto getter prefix', {ts_auto_getter_prefix}
|
|
'Auto setter prefix', {ts_auto_setter_predix}
|
|
'Thumb interworking', {ts_thumb_interworking,}
|
|
{ lowercase the first character of routine names, used to generate
|
|
names that are compliant with Java coding standards from code
|
|
written according to Delphi coding standards }
|
|
'LowerCase proc start', {ts_lowercase_proc_start,}
|
|
{ initialise local variables on the JVM target so you won't get
|
|
accidental uses of uninitialised values }
|
|
'Init locals', {ts_init_locals}
|
|
{ emit a CLD instruction before using the x86 string instructions }
|
|
'Emit CLD instruction', {ts_cld}
|
|
{ increment BP before pushing it in the function prologue and decrement
|
|
it after popping it in the function epilogue, iff the function is
|
|
going to terminate with a far ret. Thus, the BP value pushed on the
|
|
stack becomes odd if the function is far and even if the function is
|
|
near. This allows walking the BP chain on the stack and e.g.
|
|
obtaining a stack trace even if the program uses a mixture of near
|
|
and far calls. This is also required for Win16 real mode, because it
|
|
allows Windows to move code segments around (in order to defragment
|
|
memory) and then walk through the stacks of all running programs and
|
|
update the segment values of the segment that has moved. }
|
|
'Use odd BP for far procs', {ts_x86_far_procs_push_odd_bp}
|
|
'No exception support', {ts_wasm_no_exceptions}
|
|
'Branchful exceptions support', {ts_wasm_bf_exceptions}
|
|
'JavaScript-based exception support', {ts_wasm_js_exceptions}
|
|
'Native WebAssembly exceptions support', {ts_wasm_native_exceptions}
|
|
'WebAssembly threads support' {ts_wasm_threads}
|
|
);
|
|
moduleswitchname : array[tmoduleswitch] of string[40] =
|
|
('Module None', {cs_modulenone,}
|
|
{ parser }
|
|
'Floating Point Emulation',{ cs_fp_emulation}
|
|
'Extended syntax', {cs_extsyntax}
|
|
{ support }
|
|
'Goto allowed', {cs_support_goto}
|
|
'Macro support', {cs_support_macro}
|
|
'C operator support', {cs_support_c_operators}
|
|
{ generation }
|
|
'Profile', {cs_profile}
|
|
'Debug information', {cs_debuginfo}
|
|
'Compilation of System unit', {cs_compilesystem}
|
|
'Line information', {cs_lineinfo}
|
|
'Implicit exceptions', {cs_implicit_exceptions}
|
|
'Explicit CodePage', {cs_explicit_codepage}
|
|
'System CodePage', {cs_system_codepage}
|
|
{ linking }
|
|
'Create smart units', {cs_create_smart}
|
|
'Create dynamic', {cs_create_dynamic}
|
|
'Create PIC code', {cs_create_pic}
|
|
{ browser switches are back }
|
|
'Browser', {cs_browser}
|
|
'Local Browser', {cs_local_browser}
|
|
{ target specific }
|
|
'Executable Stack', {cs_executable_stack}
|
|
{ i8086 specific }
|
|
'Huge code', {cs_huge_code}
|
|
'Win16 smart callbacks', {cs_win16_smartcallbacks}
|
|
{ Record usage of checkpointer experimental feature }
|
|
'CheckPointer used', {cs_checkpointer_called}
|
|
'Supports LLVM Link-Time Optimization' {cs_lto}
|
|
,'Enable LLVM Address Sanitizer'
|
|
);
|
|
globalswitchname : array[tglobalswitch] of string[73] =
|
|
('Global None',{cs_globalnone}
|
|
{ parameter switches }
|
|
'Check unit name', {cs_check_unit_name}
|
|
'Constructor name', {cs_constructor_name}
|
|
'Support exceptions',{cs_support_exceptions}
|
|
'Support Objective-C pas',{ cs_support_c_objectivepas}
|
|
'Transparent file names', {cs_transparent_file_names}
|
|
{ units }
|
|
'Load Objpas Unit', {cs_load_objpas_unit}
|
|
'Load GPC unit', {cs_load_gpc_unit}
|
|
'Load FPCKylix unit', {cs_load_fpcylix_unit}
|
|
'Support Vectors', {cs_support_vectors}
|
|
{ debuginfo }
|
|
'Use HeapTRc unit', {cs_use_heaptrc}
|
|
'Use line information', {cs_use_lineinfo}
|
|
'Use GDB Valgrind', {cs_gdb_valgrind}
|
|
'No regalloc', {cs_no_regalloc}
|
|
'Stabs preserve cases', {cs_stabs_preservecase}
|
|
{ assembling }
|
|
'Leave assembler file', {cs_asm_leave}
|
|
'Use external assembler', {cs_asm_extern}
|
|
'Use pipes to call assembler', {cs_asm_pipe}
|
|
'Add source infos into assembler files', {cs_asm_source}
|
|
'Add RTTI infos into assembler files', {cs_asm_rtti_source}
|
|
'Add register allocation into assembler files', {cs_asm_regalloc}
|
|
'Add temporary allocation into assmebler files', {cs_asm_tempalloc}
|
|
'Add node information into assembler files', {cs_asm_nodes}
|
|
'Adapt assembler call to GNU version <= 2.25', {cs_asm_pre_binutils_2_25}
|
|
{ linking }
|
|
'Skip linking stage', {cs_link_nolink}
|
|
'Link static', {cs_link_static}
|
|
'Link smart', {cs_link_smart}
|
|
'Link shared', {cs_link_shared}
|
|
'Link deffile', {cs_link_deffile}
|
|
'Strip after linking', {cs_link_strip}
|
|
'Use linker static flag',{cs_link_staticflag}
|
|
'Link on target OS',{cs_link_on_target}
|
|
'Use external linker', {cs_link_extern}
|
|
'Link opt vtable', {cs_link_opt_vtable}
|
|
'Link opt used sections', {cs_link_opt_used_sections}
|
|
'Link debug to separate file',{cs_link_separate_dbg_file}
|
|
'Create linker map', {cs_link_map}
|
|
'Link to pthread', {cs_link_pthread}
|
|
'Link no default lib order', {cs_link_no_default_lib_order}
|
|
'Link using native linker', {cs_link_native}
|
|
'Link for GNU linker version <=2.19', {cs_link_pre_binutils_2_19}
|
|
'Link using vlink', {cs_link_vlink}
|
|
'Discard _START code', {cs_link_discard_start}
|
|
'Discard code initializing the zero register and stack pointer', {cs_link_discard_zeroreg_sp}
|
|
'Discard initializing data', {cs_link_discard_copydata}
|
|
'Discard jump to PASCALMAIN', {cs_link_discard_jmp_main}
|
|
'Link-Time Optimization disabled for system unit', {cs_lto_nosystem}
|
|
'Assemble on target OS', {cs_asemble_on_target}
|
|
'Use a memory model to support >2GB static data on 64 Bit target', {cs_large}
|
|
'Generate UF2 binary', {cs_generate_uf2}
|
|
'Link using ld.lld GNU compatible LLVM linker' {cs_link_lld}
|
|
);
|
|
localswitchname : array[tlocalswitch] of string[50] =
|
|
{ Switches which can be changed locally }
|
|
('Local None', {cs_localnone}
|
|
{ codegen }
|
|
'Check overflow', {cs_check_overflow}
|
|
'Check range', {cs_check_range}
|
|
'Check object error', {cs_check_object}
|
|
'Check I/O error', {cs_check_io}
|
|
'Check stack', {cs_check_stack}
|
|
'Check pointer', {cs_checkpointer}
|
|
'Check ordinal size', {cs_check_ordinal_size}
|
|
'Generate stackframes', {cs_generate_stackframes}
|
|
'Do assertions', {cs_do_assertion}
|
|
'Generate RTTI', {cs_generate_rtti}
|
|
'Full boolean evaluaion', {cs_full_boolean_eval}
|
|
'Typed constant are writable', {cs_typed_const_writable}
|
|
'Allow calcuation on enum types', {cs_allow_enum_calc}
|
|
'Do inline', {cs_do_inline}
|
|
'Add FWAIT instruction for FPU 8087', {cs_fpu_fwait}
|
|
'IEEE errors', {cs_ieee_errors}
|
|
'Check low address loading', {cs_check_low_addr_load}
|
|
'Imported data', {cs_imported_data}
|
|
'Excess precision', {cs_excessprecision}
|
|
'Check fpu exceptions', {cs_check_fpu_exceptions}
|
|
'Check all case coverage', {cs_check_all_case_coverage}
|
|
{ mmx }
|
|
'Allow MMX instructions', {cs_mmx}
|
|
'Use MMX saturation', {cs_mmx_saturation}
|
|
{ parser }
|
|
'Use typed addresses', {cs_typed_addresses}
|
|
'Use strict var strings', {cs_strict_var_strings}
|
|
'Use reference counted strings', {cs_refcountedstrings}
|
|
'Use bit-packing', {cs_bitpacking}
|
|
'Use var property setter', {cs_varpropsetter}
|
|
'Use scoped enums',{cs_scopedenums}
|
|
'Use pointer math', {cs_pointermath}
|
|
'Open string', {cs_openstring}
|
|
{ macpas specific}
|
|
'MACPAS exteranl variable', {cs_external_var}
|
|
'MACPAS externally visible', {cs_externally_visible}
|
|
{ jvm specific }
|
|
'JVM check var copyout', {cs_check_var_copyout}
|
|
'Zero based strings', {cs_zerobasedstrings}
|
|
{ i8086 specific }
|
|
'i8086 force FAR calls', {cs_force_far_calls}
|
|
'i8086 huge pointer arithmetic', {cs_hugeptr_arithmetic_normalization}
|
|
'i8086 huge pointer comparison', {cs_hugeptr_comparison_normalization}
|
|
'enforce legacy ifend behaviour' {cs_legacyifend}
|
|
);
|
|
{ Switches which can be changed by a mode (fpc,tp7,delphi) }
|
|
modeswitchname : array[tmodeswitch] of string[50] =
|
|
('m_none',
|
|
{ generic }
|
|
'm_fpc','m_objfpc','m_delphi','m_tp7','m_mac','m_iso','m_extpas',
|
|
{$ifdef gpc_mode}'m_gpc',{$endif}
|
|
{ more specific }
|
|
'm_class', { delphi class model }
|
|
'm_objpas', { load objpas unit }
|
|
'm_result', { result in functions }
|
|
'm_string_pchar', { pchar 2 string conversion }
|
|
'm_cvar_support', { cvar variable directive }
|
|
'm_nested_comment', { nested comments }
|
|
'm_tp_procvar', { tp style procvars (no @ needed) }
|
|
'm_mac_procvar', { macpas style procvars }
|
|
'm_repeat_forward', { repeating forward declarations is needed }
|
|
'm_pointer_2_procedure', { allows the assignement of pointers to
|
|
procedure variables }
|
|
'm_autoderef', { does auto dereferencing of struct. vars }
|
|
'm_initfinal', { initialization/finalization for units }
|
|
'm_default_ansistring', { ansistring turned on by default }
|
|
'm_out', { support the calling convention OUT }
|
|
'm_default_para', { support default parameters }
|
|
'm_hintdirective', { support hint directives }
|
|
'm_duplicate_names', { allow locals/paras to have duplicate names of globals }
|
|
'm_property', { allow properties }
|
|
'm_default_inline', { allow inline proc directive }
|
|
'm_except', { allow exception-related keywords }
|
|
'm_objectivec1', { support interfacing with Objective-C (1.0) }
|
|
'm_objectivec2', { support interfacing with Objective-C (2.0) }
|
|
'm_nested_procvars', { support nested procedural variables }
|
|
'm_non_local_goto', { support non local gotos (like iso pascal) }
|
|
'm_advanced_records', { advanced record syntax with visibility sections, methods and properties }
|
|
'm_isolike_unary_minus', { unary minus like in iso pascal: same precedence level as binary minus/plus }
|
|
'm_systemcodepage', { use system codepage as compiler codepage by default, emit ansistrings with system codepage }
|
|
'm_final_fields', { allows declaring fields as "final", which means they must be initialised
|
|
in the (class) constructor and are constant from then on (same as final
|
|
fields in Java) }
|
|
'm_default_unicodestring', { makes the default string type in $h+ mode unicodestring rather than
|
|
ansistring; similarly, char becomes unicodechar rather than ansichar }
|
|
'm_type_helpers', { allows the declaration of "type helper" for all supported types
|
|
(primitive types, records, classes, interfaces) }
|
|
'm_blocks', { support for http://en.wikipedia.org/wiki/Blocks_(C_language_extension) }
|
|
'm_isolike_io', { I/O as it required by an ISO compatible compiler }
|
|
'm_isolike_program_para',{ program parameters as it required by an ISO compatible compiler }
|
|
'm_isolike_mod', { mod operation as it is required by an iso compatible compiler }
|
|
'm_array_operators', { use Delphi compatible array operators instead of custom ones ("+") }
|
|
'm_multi_helpers', { helpers can appear in multiple scopes simultaneously }
|
|
'm_array2dynarray', { regular arrays can be implicitly converted to dynamic arrays }
|
|
'm_prefixed_attributes', { enable attributes that are defined before the type they belong to }
|
|
'm_underscoreisseparator',{ _ can be used as separator to group digits in numbers }
|
|
'm_implicit_function_specialization', { attempt to specialize generic function by inferring types from parameters }
|
|
'm_function_references', { enable Delphi-style function references }
|
|
'm_anonymous_functions' { enable Delphi-style anonymous functions }
|
|
);
|
|
{ optimizer }
|
|
optimizerswitchname : array[toptimizerswitch] of string[50] =
|
|
('cs_opt_level1',
|
|
'cs_opt_level2',
|
|
'cs_opt_level3',
|
|
'cs_opt_level4',
|
|
'cs_opt_regvar',
|
|
'cs_opt_uncertain',
|
|
'cs_opt_size',
|
|
'cs_opt_stackframe',
|
|
'cs_opt_peephole',
|
|
'cs_opt_loopunroll',
|
|
'cs_opt_tailrecursion',
|
|
'cs_opt_nodecse',
|
|
'cs_opt_nodedfa',
|
|
'cs_opt_loopstrength',
|
|
'cs_opt_scheduler',
|
|
'cs_opt_autoinline',
|
|
'cs_useebp',
|
|
'cs_userbp',
|
|
'cs_opt_reorder_fields',
|
|
'cs_opt_fastmath',
|
|
{ Allow removing expressions whose result is not used, even when this
|
|
can change program behaviour (range check errors disappear',
|
|
access violations due to invalid pointer derefences disappear, ...).
|
|
Note: it does not (and must not) remove expressions that have
|
|
explicit side-effects, only implicit side-effects (like the ones
|
|
mentioned before) can disappear.
|
|
}
|
|
'cs_opt_dead_values',
|
|
{ compiler checks for empty procedures/methods and removes calls to them if possible }
|
|
'cs_opt_remove_empty_proc',
|
|
'cs_opt_constant_propagate',
|
|
'cs_opt_dead_store_eliminate',
|
|
'cs_opt_forcenostackframe',
|
|
'cs_opt_use_load_modify_store',
|
|
'cs_opt_unused_para',
|
|
'cs_opt_consts',
|
|
'cs_opt_forloop'
|
|
);
|
|
var
|
|
globalswitch : tglobalswitch;
|
|
targetswitch : ttargetswitch;
|
|
moduleswitch : tmoduleswitch;
|
|
localswitch : tlocalswitch;
|
|
modeswitch : tmodeswitch;
|
|
optimizerswitch : toptimizerswitch;
|
|
globalswitches : tglobalswitches;
|
|
targetswitches : ttargetswitches;
|
|
moduleswitches : tmoduleswitches;
|
|
localswitches : tlocalswitches;
|
|
modeswitches : tmodeswitches;
|
|
optimizerswitches : toptimizerswitches;
|
|
begin
|
|
{alignment : talignmentinfo;}
|
|
{talignmentinfo = packed record}
|
|
writeln('Procedure alignment: '+tostr(new_settings.alignment.procalign));
|
|
writeln('Loop alignment: '+tostr(new_settings.alignment.loopalign));
|
|
{ alignment for labels after unconditional jumps, this must be a power of two }
|
|
writeln('Jump alignment: '+tostr(new_settings.alignment.jumpalign));
|
|
{ max. alignment for labels after unconditional jumps:
|
|
the compiler tries to align jumpalign, however, to do so it inserts at maximum jumpalignskipmax bytes or uses
|
|
the next smaller power of two of jumpalign }
|
|
writeln('Jump skip max alignment: '+tostr(new_settings.alignment.jumpalignskipmax));
|
|
{ alignment for labels where two flows of the program flow coalesce, this must be a power of two }
|
|
writeln('Coalescence alignment: '+tostr(new_settings.alignment.coalescealign));
|
|
{ max. alignment for labels where two flows of the program flow coalesce
|
|
the compiler tries to align to coalescealign, however, to do so it inserts at maximum coalescealignskipmax bytes or uses
|
|
the next smaller power of two of coalescealign }
|
|
writeln('Coalescence skip max alignment: '+tostr(new_settings.alignment.coalescealignskipmax));
|
|
writeln('Const min alignment: '+tostr(new_settings.alignment.constalignmin));
|
|
writeln('Const max alignment: '+tostr(new_settings.alignment.constalignmax));
|
|
writeln('Var min alignment: '+tostr(new_settings.alignment.varalignmin));
|
|
writeln('Var max alignment: '+tostr(new_settings.alignment.varalignmax));
|
|
writeln('Local min alignment: '+tostr(new_settings.alignment.localalignmin));
|
|
writeln('Local max alignment: '+tostr(new_settings.alignment.localalignmax));
|
|
writeln('Min record alignment: '+tostr(new_settings.alignment.recordalignmin));
|
|
writeln('Max record alignment: '+tostr(new_settings.alignment.recordalignmax));
|
|
writeln('Max C record alignment: '+tostr(new_settings.alignment.maxCrecordalign));
|
|
globalswitches:=new_settings.globalswitches;
|
|
for globalswitch:=low(tglobalswitch) to high(tglobalswitch) do
|
|
if globalswitch in globalswitches then
|
|
begin
|
|
writeln('global switch: '+globalswitchname[globalswitch]);
|
|
exclude(globalswitches,globalswitch);
|
|
end;
|
|
if (globalswitches <> []) then
|
|
writeln('Unknown global switch');
|
|
targetswitches:=new_settings.targetswitches;
|
|
for targetswitch:=low(ttargetswitch) to high(ttargetswitch) do
|
|
if targetswitch in targetswitches then
|
|
begin
|
|
writeln('target switch: '+targetswitchname[targetswitch]);
|
|
exclude(targetswitches,targetswitch);
|
|
end;
|
|
if (targetswitches <> []) then
|
|
writeln('Unknown target switch');
|
|
moduleswitches:=new_settings.moduleswitches;
|
|
for moduleswitch:=low(tmoduleswitch) to high(tmoduleswitch) do
|
|
if moduleswitch in moduleswitches then
|
|
begin
|
|
writeln('module switch: '+moduleswitchname[moduleswitch]);
|
|
exclude(moduleswitches,moduleswitch);
|
|
end;
|
|
if (moduleswitches <> []) then
|
|
writeln('Unknown module switch');
|
|
localswitches:=new_settings.localswitches;
|
|
for localswitch:=low(tlocalswitch) to high(tlocalswitch) do
|
|
if localswitch in localswitches then
|
|
begin
|
|
writeln('local switch: '+localswitchname[localswitch]);
|
|
exclude(localswitches,localswitch);
|
|
end;
|
|
if (localswitches <> []) then
|
|
writeln('Unknown local switch');
|
|
modeswitches:=new_settings.modeswitches;
|
|
for modeswitch:=low(tmodeswitch) to high(tmodeswitch) do
|
|
if modeswitch in modeswitches then
|
|
begin
|
|
writeln(['mode switch: ',modeswitchname[modeswitch]]);
|
|
exclude(modeswitches,modeswitch);
|
|
end;
|
|
if (modeswitches <> []) then
|
|
writeln('Unknown mode switch');
|
|
optimizerswitches:=new_settings.optimizerswitches;
|
|
for optimizerswitch:=low(toptimizerswitch) to high(toptimizerswitch) do
|
|
if optimizerswitch in optimizerswitches then
|
|
begin
|
|
writeln(['optimizer switch: ',optimizerswitchname[optimizerswitch]]);
|
|
exclude(optimizerswitches,optimizerswitch);
|
|
end;
|
|
if (optimizerswitches <> []) then
|
|
writeln('Unknown optimizer switch');
|
|
writeln(['Set allocation size ',new_settings.setalloc]);
|
|
writeln(['Pack enums ',new_settings.packenum]);
|
|
writeln(['Pack records ',new_settings.packrecords]);
|
|
writeln(['Max FPU registers ',new_settings.maxfpuregisters]);
|
|
|
|
writeln(['CPU type ',new_settings.cputype]);
|
|
writeln(['CPU optimize type ',new_settings.optimizecputype]);
|
|
writeln(['FPU type ',new_settings.fputype]);
|
|
writeln(['ASM mode ',new_settings.asmmode]);
|
|
end;
|
|
|
|
var
|
|
linestr,genstr : string;
|
|
token : ttoken;
|
|
copy_size, stbi, last_col, new_col : longint;
|
|
last_line,new_line : dword;
|
|
len : sizeint;
|
|
wstring : widestring;
|
|
astring : ansistring;
|
|
begin
|
|
tbi:=0;
|
|
last_line:=0;
|
|
last_col:=0;
|
|
linestr:='';
|
|
genstr:='';
|
|
fillchar(new_settings,sizeof(new_settings),#0);
|
|
fillchar(prev_settings,sizeof(prev_settings),#0);
|
|
write([space,' Tokens: ']);
|
|
while tbi<tokenbufsize do
|
|
begin
|
|
token:=readtoken;
|
|
if token<>_GENERICSPECIALTOKEN then
|
|
begin
|
|
if token <= high(ttoken) then
|
|
begin
|
|
write(arraytokeninfo[token].str);
|
|
if not (token in [_CWCHAR, _CWSTRING, _CSTRING, _CCHAR,
|
|
_INTCONST,_REALNUMBER, _ID]) then
|
|
StrAppend(linestr,lowercase(arraytokeninfo[token].str));
|
|
end
|
|
else
|
|
begin
|
|
HasMoreInfos;
|
|
write('Error in Token List');
|
|
break;
|
|
end;
|
|
{idtoken:=}readtoken;
|
|
end;
|
|
case token of
|
|
_CWCHAR,
|
|
_CWSTRING :
|
|
begin
|
|
len:=gettokenbufsizeint;
|
|
setlength(wstring,len);
|
|
move(tokenbuf[tbi],wstring[1],len*2);
|
|
write([' ''',wstring,'''']);
|
|
StrAppend(linestr,' ''');
|
|
StrAppend(linestr,wstring);
|
|
StrAppend(linestr,'''');
|
|
inc(tbi,len*2);
|
|
end;
|
|
_CSTRING:
|
|
begin
|
|
len:=gettokenbufsizeint;
|
|
setlength(astring,len);
|
|
if len>0 then
|
|
move(tokenbuf[tbi],astring[1],len);
|
|
write([' ''',astring,'''']);
|
|
StrAppend(linestr,' ''');
|
|
StrAppend(linestr,astring);
|
|
StrAppend(linestr,'''');
|
|
inc(tbi,len);
|
|
end;
|
|
_CCHAR:
|
|
begin
|
|
write([' ''',unaligned(pshortstring(@tokenbuf[tbi])^),'''']);
|
|
StrAppend(linestr,' ''');
|
|
StrAppend(linestr,unaligned(pshortstring(@tokenbuf[tbi])^));
|
|
StrAppend(linestr,'''');
|
|
inc(tbi,tokenbuf[tbi]+1);
|
|
end;
|
|
_INTCONST,
|
|
_REALNUMBER :
|
|
begin
|
|
write([' ',unaligned(pshortstring(@tokenbuf[tbi])^)]);
|
|
StrAppend(linestr,unaligned(pshortstring(@tokenbuf[tbi])^));
|
|
inc(tbi,tokenbuf[tbi]+1);
|
|
end;
|
|
_ID :
|
|
begin
|
|
write([' ',unaligned(pshortstring(@tokenbuf[tbi])^)]);
|
|
StrAppend(linestr,unaligned(pshortstring(@tokenbuf[tbi])^));
|
|
inc(tbi,tokenbuf[tbi]+1);
|
|
end;
|
|
_GENERICSPECIALTOKEN:
|
|
begin
|
|
{ Short version of column change,
|
|
byte or $80 used }
|
|
if (tokenbuf[tbi] and $80)<>0 then
|
|
begin
|
|
new_col:=tokenbuf[tbi] and $7f;
|
|
write(['Col: ',new_col]);
|
|
if length(linestr)<new_col-1 then
|
|
StrAppend(linestr,StringOfChar(' ',new_col - 1 - length(linestr)));
|
|
inc(tbi);
|
|
last_col:=new_col;
|
|
end
|
|
else
|
|
case tspecialgenerictoken(tokenbuf[tbi]) of
|
|
ST_LOADSETTINGS:
|
|
begin
|
|
inc(tbi);
|
|
write([space,'Settings: ']);
|
|
fillchar(new_settings,sizeof(new_settings),#0);
|
|
{ This does not load pmessage pointer }
|
|
new_settings.pmessage:=nil;
|
|
{ TSettings size depends in target...
|
|
We first read the size of the copied part }
|
|
{ Still not cross endian ready :( }
|
|
copy_size:=gettokenbufsizeint;
|
|
stbi:=tbi;
|
|
tokenreadsettings(new_settings, copy_size);
|
|
tbi:=stbi+copy_size;
|
|
if CompareByte(new_settings,prev_settings,copy_size)<>0 then
|
|
begin
|
|
dump_new_settings;
|
|
writeln;
|
|
end
|
|
else
|
|
begin
|
|
writeln('Unchanged');
|
|
end;
|
|
prev_settings:=new_settings;
|
|
end;
|
|
ST_LOADMESSAGES:
|
|
begin
|
|
inc(tbi);
|
|
mesgnb:=gettokenbufsizeint;;
|
|
writeln([space,mesgnb,' messages: ']);
|
|
if (tbi+2*sizeof(longint)*mesgnb>tokenbufsize) then
|
|
begin
|
|
WriteError('!! Error: number of messages incompatible with token buffer size');
|
|
end;
|
|
for nb:=1 to mesgnb do
|
|
begin
|
|
msgvalue:=gettokenbuflongint;
|
|
state:=tmsgstate(gettokenbuflongint);
|
|
writeln(['#',msgvalue,' ',state]);
|
|
end;
|
|
end;
|
|
ST_LINE:
|
|
begin
|
|
inc(tbi);
|
|
new_line:=gettokenbufdword;
|
|
if (new_line<>last_line) then
|
|
begin
|
|
StrAppend(genstr,linestr+LineEnding);
|
|
linestr:='';
|
|
end;
|
|
writeln(['Line: ',new_line]);
|
|
last_line:=new_line;
|
|
end;
|
|
ST_COLUMN:
|
|
begin
|
|
inc(tbi);
|
|
new_col:=gettokenbufword;
|
|
write(['Col: ',new_col]);
|
|
if length(linestr)<new_col - 1 then
|
|
StrAppend(linestr,StringOfChar(' ',new_col - 1 - length(linestr)));
|
|
last_col:=new_col;
|
|
end;
|
|
ST_FILEINDEX:
|
|
begin
|
|
inc(tbi);
|
|
StrAppend(genstr,linestr+LineEnding);
|
|
linestr:='';
|
|
write(['File: ',gettokenbufword]);
|
|
end;
|
|
else
|
|
begin
|
|
HasMoreInfos;
|
|
write('Error in Token List');
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
else ; { empty else to avoid warning }
|
|
end;
|
|
|
|
if tbi<tokenbufsize then
|
|
write(',');
|
|
end;
|
|
if (tbi>tokenbufsize) then
|
|
begin
|
|
WriteError('!! Error: read past of token buffer size');
|
|
end
|
|
else
|
|
writeln;
|
|
StrAppend(genstr,linestr);
|
|
writeln(['##',genstr,'##']);
|
|
end;
|
|
|
|
procedure readcommondef(const s:string; out defoptions: tdefoptions; Def: TPpuDef = nil);
|
|
type
|
|
tdefopt=record
|
|
mask : tdefoption;
|
|
str : string[30];
|
|
end;
|
|
tdefstateinfo=record
|
|
mask : tdefstate;
|
|
str : string[30];
|
|
end;
|
|
tgenconstrflag=record
|
|
mask : tgenericconstraintflag;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
defopt : array[1..ord(high(tdefoption))] of tdefopt=(
|
|
(mask:df_unique; str:'Unique Type'),
|
|
(mask:df_generic; str:'Generic'),
|
|
(mask:df_specialization; str:'Specialization'),
|
|
(mask:df_copied_def; str:'Copied Typedef'),
|
|
(mask:df_genconstraint; str:'Generic Constraint'),
|
|
{ this should never happen for defs stored to a ppu file }
|
|
(mask:df_not_registered_no_free; str:'Unregistered/No free (invalid)'),
|
|
(mask:df_llvm_no_struct_packing; str:'LLVM unpacked struct'),
|
|
(mask:df_internal; str:'Internal'),
|
|
(mask:df_has_global_ref; str:'Has Global Ref'),
|
|
(mask:df_has_generic_fields; str:'Has generic fields'),
|
|
(mask:df_llvm_no_typename; str:'LLVM no typename')
|
|
);
|
|
defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=(
|
|
(mask:ds_vmt_written; str:'VMT Written'),
|
|
(mask:ds_rtti_table_used; str:'RTTITable Used'),
|
|
(mask:ds_init_table_used; str:'InitTable Used'),
|
|
(mask:ds_rtti_table_written; str:'RTTITable Written'),
|
|
(mask:ds_init_table_written; str:'InitTable Written'),
|
|
(mask:ds_dwarf_dbg_info_used; str:'Dwarf DbgInfo Used'),
|
|
(mask:ds_dwarf_dbg_info_written;str:'Dwarf DbgInfo Written')
|
|
);
|
|
genconstrflag : array[1..ord(high(tgenericconstraintflag))] of tgenconstrflag=(
|
|
(mask:gcf_constructor; str:'Constructor'),
|
|
(mask:gcf_class; str:'Class'),
|
|
(mask:gcf_record; str:'Record')
|
|
);
|
|
|
|
var
|
|
defstates : tdefstates;
|
|
i, nb, len : longint;
|
|
first : boolean;
|
|
min_size, tokenbufsize : longint;
|
|
tokenbuf : pbyte;
|
|
genconstr : tgenericconstraintflags;
|
|
begin
|
|
i:=ppufile.getlongint;
|
|
if Def <> nil then
|
|
Def.Id:=i;
|
|
writeln([space,'** Definition Id ',i,' **']);
|
|
writeln([space,s]);
|
|
write ([space,' Type symbol : ']);
|
|
if Def <> nil then
|
|
readderef('', Def.Ref)
|
|
else
|
|
readderef('');
|
|
write ([space,' DefOptions : ']);
|
|
ppufile.getset(tppuset2(defoptions));
|
|
if defoptions<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1to high(defopt) do
|
|
if (defopt[i].mask in defoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(defopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
|
|
write ([space,' DefStates : ']);
|
|
ppufile.getset(tppuset1(defstates));
|
|
if defstates<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to high(defstate) do
|
|
if (defstate[i].mask in defstates) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(defstate[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
|
|
if df_unique in defoptions then
|
|
begin
|
|
write ([space,' OriginalDef : ']);
|
|
readderef(space);
|
|
end;
|
|
|
|
if df_genconstraint in defoptions then
|
|
begin
|
|
ppufile.getset(tppuset1(genconstr));
|
|
write ([space,' GenConstraints : ']);
|
|
if genconstr<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to high(genconstrflag) do
|
|
if (genconstrflag[i].mask in genconstr) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(genconstrflag[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
|
|
len:=ppufile.getlongint;
|
|
if len>0 then
|
|
begin
|
|
space:=' '+space;
|
|
writeln([space,'------ constraint defs begin ------']);
|
|
for i:=0 to len-1 do
|
|
begin
|
|
writeln([space,'------ constraint def ',i,' ------']);
|
|
readderef(space);
|
|
end;
|
|
writeln([space,'------ constraint defs end ------']);
|
|
delete(space,1,4);
|
|
end;
|
|
end;
|
|
|
|
if [df_generic,df_specialization]*defoptions<>[] then
|
|
begin
|
|
nb:=ppufile.getlongint;
|
|
writeln([space,'has ',nb,' parameters']);
|
|
if nb>0 then
|
|
begin
|
|
for i:=0 to nb-1 do
|
|
begin
|
|
writeln([space,'parameter ',i,': ',ppufile.getstring]);
|
|
readderef(space);
|
|
end;
|
|
end;
|
|
end;
|
|
if df_generic in defoptions then
|
|
begin
|
|
tokenbufsize:=ppufile.getlongint;
|
|
writeln([space,' Tokenbuffer size : ',tokenbufsize]);
|
|
tokenbuf:=allocmem(tokenbufsize);
|
|
ppufile.getdata(tokenbuf^,tokenbufsize);
|
|
displaytokenbuffer(tokenbuf,tokenbufsize);
|
|
freemem(tokenbuf);
|
|
end;
|
|
if df_specialization in defoptions then
|
|
begin
|
|
write ([space,' Orig. GenericDef : ']);
|
|
readderef('');
|
|
end;
|
|
space:=space+' ';
|
|
readattrs(def);
|
|
delete(space,1,4);
|
|
current_defoptions:=defoptions;
|
|
end;
|
|
|
|
|
|
{ Read abstract procdef and return if inline procdef }
|
|
{ type tproccalloption is in globtype unit }
|
|
{ type tproctypeoption is in globtype unit }
|
|
{ type tprocoption is in globtype unit }
|
|
|
|
procedure read_abstract_proc_def(var proccalloption:tproccalloption;var procoptions:tprocoptions; ProcDef: TPpuProcDef);
|
|
type
|
|
tproccallopt=record
|
|
mask : tproccalloption;
|
|
str : string[30];
|
|
end;
|
|
tproctypeopt=record
|
|
mask : tproctypeoption;
|
|
str : string[30];
|
|
end;
|
|
tprocopt=record
|
|
mask : tprocoption;
|
|
str : string[34];
|
|
end;
|
|
const
|
|
{proccalloptionStr is also in globtype unit }
|
|
proctypeopt : array[1..ord(high(tproctypeoption))] of tproctypeopt=(
|
|
(mask:potype_proginit; str:'ProgInit'),
|
|
(mask:potype_unitinit; str:'UnitInit'),
|
|
(mask:potype_unitfinalize; str:'UnitFinalize'),
|
|
(mask:potype_constructor; str:'Constructor'),
|
|
(mask:potype_destructor; str:'Destructor'),
|
|
(mask:potype_operator; str:'Operator'),
|
|
(mask:potype_procedure; str:'Procedure'),
|
|
(mask:potype_function; str:'Function'),
|
|
(mask:potype_class_constructor; str:'Class Constructor'),
|
|
(mask:potype_class_destructor; str:'Class Destructor'),
|
|
{ Dispinterface property accessors }
|
|
(mask:potype_propgetter; str:'Property Getter'),
|
|
(mask:potype_propsetter; str:'Property Setter'),
|
|
(mask:potype_exceptfilter; str:'SEH filter'),
|
|
(mask:potype_mainstub; str:'main stub'),
|
|
(mask:potype_pkgstub; str:'package stub'),
|
|
(mask:potype_libmainstub; str:'library main stub')
|
|
);
|
|
procopt : array[1..ord(high(tprocoption))] of tprocopt=(
|
|
(mask:po_classmethod; str:'ClassMethod'),
|
|
(mask:po_virtualmethod; str:'VirtualMethod'),
|
|
(mask:po_abstractmethod; str:'AbstractMethod'),
|
|
(mask:po_finalmethod; str:'FinalMethod'),
|
|
(mask:po_staticmethod; str:'StaticMethod'),
|
|
(mask:po_overridingmethod;str:'OverridingMethod'),
|
|
(mask:po_methodpointer; str:'MethodPointer'),
|
|
(mask:po_interrupt; str:'Interrupt'),
|
|
(mask:po_iocheck; str:'IOCheck'),
|
|
(mask:po_assembler; str:'Assembler'),
|
|
(mask:po_msgstr; str:'MsgStr'),
|
|
(mask:po_msgint; str:'MsgInt'),
|
|
(mask:po_exports; str:'Exports'),
|
|
(mask:po_external; str:'External'),
|
|
(mask:po_overload; str:'Overload'),
|
|
(mask:po_varargs; str:'VarArgs'),
|
|
(mask:po_internconst; str:'InternConst'),
|
|
(mask:po_addressonly; str:'AddressOnly'),
|
|
(mask:po_public; str:'Public'),
|
|
(mask:po_hascallingconvention;str:'HasCallingConvention'),
|
|
(mask:po_reintroduce; str:'ReIntroduce'),
|
|
(mask:po_explicitparaloc; str:'ExplicitParaloc'),
|
|
(mask:po_nostackframe; str:'NoStackFrame'),
|
|
(mask:po_has_mangledname; str:'HasMangledName'),
|
|
(mask:po_has_public_name; str:'HasPublicName'),
|
|
(mask:po_forward; str:'Forward'),
|
|
(mask:po_global; str:'Global'),
|
|
(mask:po_syscall; str:'Syscall'),
|
|
(mask:po_syscall_legacy; str:'SyscallLegacy'),
|
|
(mask:po_syscall_basenone;str:'SyscallBaseNone'),
|
|
(mask:po_syscall_basefirst;str:'SyscallBaseFirst'),
|
|
(mask:po_syscall_baselast;str:'SyscallBaseLast'),
|
|
(mask:po_syscall_basereg; str:'SyscallBaseReg'),
|
|
(mask:po_syscall_has_libsym; str:'Has LibSym'),
|
|
(mask:po_syscall_has_importnr; str:'Uses ImportNr'),
|
|
(mask:po_inline; str:'Inline'),
|
|
(mask:po_compilerproc; str:'CompilerProc'),
|
|
(mask:po_has_importdll; str:'HasImportDLL'),
|
|
(mask:po_has_importname; str:'HasImportName'),
|
|
(mask:po_kylixlocal; str:'KylixLocal'),
|
|
(mask:po_dispid; str:'DispId'),
|
|
(mask:po_weakexternal; str:'WeakExternal'),
|
|
(mask:po_objc; str:'ObjC'),
|
|
(mask:po_enumerator_movenext; str:'EnumeratorMoveNext'),
|
|
(mask:po_optional; str: 'Optional'),
|
|
(mask:po_delphi_nested_cc;str: 'Delphi-style nested frameptr'),
|
|
(mask:po_java_nonvirtual; str: 'Java non-virtual method'),
|
|
(mask:po_ignore_for_overload_resolution;str: 'Ignored for overload resolution'),
|
|
(mask:po_rtlproc; str: 'RTL procedure'),
|
|
(mask:po_auto_raised_visibility; str: 'Visibility raised by compiler'),
|
|
(mask:po_far; str: 'Far'),
|
|
(mask:po_hasnearfarcallmodel; str: 'Near/Far explicit'),
|
|
(mask:po_noreturn; str: 'No return'),
|
|
(mask:po_is_function_ref; str: 'Function reference'),
|
|
(mask:po_is_block; str: 'C "Block"'),
|
|
(mask:po_is_auto_getter; str: 'Automatically generated getter'),
|
|
(mask:po_is_auto_setter; str: 'Automatically generated setter'),
|
|
(mask:po_noinline; str: 'Never inline'),
|
|
(mask:po_variadic; str: 'C VarArgs with array-of-const para'),
|
|
(mask:po_objc_related_result_type; str: 'Objective-C related result type'),
|
|
(mask:po_anonymous; str: 'Anonymous'),
|
|
(mask:po_wasm_funcref; str: 'WebAssembly funcref'),
|
|
(mask:po_wasm_suspending; str: 'WebAssembly suspending')
|
|
);
|
|
var
|
|
proctypeoption : tproctypeoption;
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
write([space,' Return type : ']);
|
|
readderef('', ProcDef.ReturnType);
|
|
proctypeoption:=tproctypeoption(ppufile.getbyte);
|
|
case proctypeoption of
|
|
potype_function: Include(ProcDef.Options, poFunction);
|
|
potype_procedure: Include(ProcDef.Options, poProcedure);
|
|
potype_constructor: Include(ProcDef.Options, poConstructor);
|
|
potype_destructor: Include(ProcDef.Options, poDestructor);
|
|
potype_operator: Include(ProcDef.Options, poOperator);
|
|
end;
|
|
write([space,' TypeOption : ']);
|
|
first:=true;
|
|
for i:=1 to high(proctypeopt) do
|
|
if (proctypeopt[i].mask=proctypeoption) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(proctypeopt[i].str);
|
|
end;
|
|
writeln;
|
|
proccalloption:=tproccalloption(ppufile.getbyte);
|
|
writeln([space,' CallOption : ',proccalloptionStr[proccalloption]]);
|
|
ppufile.getset(tppuset8(procoptions));
|
|
if procoptions<>[] then
|
|
begin
|
|
if po_classmethod in procoptions then Include(ProcDef.Options, poClassMethod);
|
|
if po_virtualmethod in procoptions then Include(ProcDef.Options, poVirtual);
|
|
if po_abstractmethod in procoptions then Include(ProcDef.Options, poAbstract);
|
|
if po_overridingmethod in procoptions then Include(ProcDef.Options, poOverriding);
|
|
if po_overload in procoptions then Include(ProcDef.Options, poOverload);
|
|
if po_inline in procoptions then Include(ProcDef.Options, poInline);
|
|
if (po_methodpointer in procoptions) and (ProcDef.DefType = dtProcType) then
|
|
TPpuProcTypeDef(ProcDef).MethodPtr:=True;
|
|
|
|
write([space,' Options : ']);
|
|
first:=true;
|
|
for i:=1 to high(procopt) do
|
|
if (procopt[i].mask in procoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(procopt[i].str);
|
|
end;
|
|
writeln;
|
|
end;
|
|
if (po_explicitparaloc in procoptions) then
|
|
begin
|
|
readcgpara(space);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ type tvaroption is in unit symconst }
|
|
{ register variable }
|
|
{ type tvarregable is in unit symconst }
|
|
procedure readabstractvarsym(const s:string;var varoptions:tvaroptions; VarDef: TPpuVarDef = nil);
|
|
type
|
|
tvaropt=record
|
|
mask : tvaroption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
varopt : array[1..ord(high(tvaroption))] of tvaropt=(
|
|
(mask:vo_is_external; str:'External'),
|
|
(mask:vo_is_dll_var; str:'DLLVar'),
|
|
(mask:vo_is_thread_var; str:'ThreadVar'),
|
|
(mask:vo_has_local_copy; str:'HasLocalCopy'),
|
|
(mask:vo_is_const; str:'Constant'),
|
|
(mask:vo_is_public; str:'Public'),
|
|
(mask:vo_is_high_para; str:'HighValue'),
|
|
(mask:vo_is_funcret; str:'Funcret'),
|
|
(mask:vo_is_self; str:'Self'),
|
|
(mask:vo_is_vmt; str:'VMT'),
|
|
(mask:vo_is_result; str:'Result'),
|
|
(mask:vo_is_parentfp; str:'ParentFP'),
|
|
(mask:vo_is_loop_counter; str:'LoopCounter'),
|
|
(mask:vo_is_hidden_para; str:'Hidden'),
|
|
(mask:vo_has_explicit_paraloc;str:'ExplicitParaloc'),
|
|
(mask:vo_is_syscall_lib; str:'SysCallLib'),
|
|
(mask:vo_has_mangledname; str:'HasMangledName'),
|
|
(mask:vo_is_typed_const; str:'TypedConst'),
|
|
(mask:vo_is_range_check; str:'RangeCheckSwitch'),
|
|
(mask:vo_is_overflow_check; str:'OverflowCheckSwitch'),
|
|
(mask:vo_is_typinfo_para; str:'TypeInfo'),
|
|
(mask:vo_is_msgsel;str:'MsgSel'),
|
|
(mask:vo_is_weak_external;str:'WeakExternal'),
|
|
(mask:vo_is_first_field;str:'IsFirstField'),
|
|
(mask:vo_volatile; str:'Volatile'),
|
|
(mask:vo_has_section; str:'HasSection'),
|
|
(mask:vo_force_finalize; str:'ForceFinalize'),
|
|
(mask:vo_is_default_var; str:'DefaultIntrinsicVar'),
|
|
(mask:vo_is_far; str:'IsFar'),
|
|
(mask:vo_has_global_ref; str:'HasGlobalRef'),
|
|
(mask:vo_is_internal; str:'IsInternal')
|
|
);
|
|
type
|
|
tvaraccessdesc=record
|
|
mask: tvarsymaccessflag;
|
|
str: string[30];
|
|
end;
|
|
const
|
|
varaccessstr : array[ord(low(tvarsymaccessflag))..ord(high(tvarsymaccessflag))] of tvaraccessdesc=(
|
|
(mask: vsa_addr_taken; str:'Address taken'),
|
|
(mask: vsa_different_scope; str:'Accessed from different scope')
|
|
);
|
|
var
|
|
i : longint;
|
|
accessflag: tvarsymaccessflag;
|
|
varsymaccessflags: tvarsymaccessflags;
|
|
first : boolean;
|
|
begin
|
|
readcommonsym(s, VarDef);
|
|
i:=ppufile.getbyte;
|
|
if (VarDef <> nil) and (VarDef.DefType = dtParam) then
|
|
with TPpuParamDef(VarDef) do
|
|
case tvarspez(i) of
|
|
vs_value: Spez:=psValue;
|
|
vs_var: Spez:=psVar;
|
|
vs_out: Spez:=psOut;
|
|
vs_const: Spez:=psConst;
|
|
vs_constref: Spez:=psConstRef;
|
|
end;
|
|
writeln([space,' Spez : ',Varspez2Str(i)]);
|
|
writeln([space,' Regable : ',Varregable2Str(ppufile.getbyte)]);
|
|
ppufile.getset(tppuset1(varsymaccessflags));
|
|
write([space, ' Access Flags : ']);
|
|
first:=true;
|
|
for i:=low(varaccessstr) to high(varaccessstr) do
|
|
begin
|
|
if varaccessstr[i].mask in varsymaccessflags then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write([', ']);
|
|
write([varaccessstr[i].str]);
|
|
end
|
|
end;
|
|
writeln;
|
|
write ([space,' Var Type : ']);
|
|
if VarDef <> nil then
|
|
readderef('',VarDef.VarType)
|
|
else
|
|
readderef('');
|
|
ppufile.getset(tppuset4(varoptions));
|
|
if varoptions<>[] then
|
|
begin
|
|
if (VarDef <> nil) and (VarDef.DefType = dtParam) and (vo_is_hidden_para in varoptions) then
|
|
TPpuParamDef(VarDef).Spez:=psHidden;
|
|
write([space,' Options : ']);
|
|
first:=true;
|
|
for i:=1 to high(varopt) do
|
|
if (varopt[i].mask in varoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(varopt[i].str);
|
|
end;
|
|
writeln;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure readobjectdefoptions(ObjDef: TPpuObjectDef = nil);
|
|
type
|
|
tsymopt=record
|
|
mask : tobjectoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
symopt : array[1..ord(high(tobjectoption))] of tsymopt=(
|
|
(mask:oo_is_forward; str:'IsForward'),
|
|
(mask:oo_is_abstract; str:'IsAbstract'),
|
|
(mask:oo_is_sealed; str:'IsSealed'),
|
|
(mask:oo_has_virtual; str:'HasVirtual'),
|
|
(mask:oo_has_private; str:'HasPrivate'),
|
|
(mask:oo_has_protected; str:'HasProtected'),
|
|
(mask:oo_has_strictprivate; str:'HasStrictPrivate'),
|
|
(mask:oo_has_strictprotected;str:'HasStrictProtected'),
|
|
(mask:oo_has_constructor; str:'HasConstructor'),
|
|
(mask:oo_has_destructor; str:'HasDestructor'),
|
|
(mask:oo_has_vmt; str:'HasVMT'),
|
|
(mask:oo_has_msgstr; str:'HasMsgStr'),
|
|
(mask:oo_has_msgint; str:'HasMsgInt'),
|
|
(mask:oo_can_have_published; str:'CanHavePublished'),
|
|
(mask:oo_has_default_property;str:'HasDefaultProperty'),
|
|
(mask:oo_has_valid_guid; str:'HasValidGUID'),
|
|
(mask:oo_has_enumerator_movenext; str:'HasEnumeratorMoveNext'),
|
|
(mask:oo_has_enumerator_current; str:'HasEnumeratorCurrent'),
|
|
(mask:oo_is_external; str:'External'),
|
|
(mask:oo_is_formal; str:'Formal'),
|
|
(mask:oo_is_classhelper; str:'Class Helper/Category'),
|
|
(mask:oo_has_class_constructor; str:'HasClassConstructor'),
|
|
(mask:oo_has_class_destructor; str:'HasClassDestructor'),
|
|
(mask:oo_is_enum_class; str:'JvmEnumClass'),
|
|
(mask:oo_has_new_destructor; str:'HasNewDestructor'),
|
|
(mask:oo_is_funcref; str:'IsFuncRef'),
|
|
(mask:oo_is_invokable; str:'IsInvokable'),
|
|
(mask:oo_is_capturer; str:'IsCapturer'),
|
|
(mask:oo_inherits_not_specialized; str:'InheritedNotSpecialized')
|
|
);
|
|
var
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset4(current_objectoptions));
|
|
if current_objectoptions<>[] then
|
|
begin
|
|
if ObjDef <> nil then
|
|
begin
|
|
if oo_is_abstract in current_objectoptions then
|
|
Include(ObjDef.Options, ooIsAbstract);
|
|
end;
|
|
first:=true;
|
|
for i:=1 to high(symopt) do
|
|
if (symopt[i].mask in current_objectoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(symopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
|
|
|
|
procedure readextendedrtti;
|
|
type
|
|
tvisopt=record
|
|
mask : trtti_visibility;
|
|
str : string[10];
|
|
end;
|
|
const
|
|
visopt : array[0..ord(high(trtti_visibility))] of tvisopt=(
|
|
(mask:rv_private; str:'Private'),
|
|
(mask:rv_protected; str:'Protected'),
|
|
(mask:rv_public; str:'Public'),
|
|
(mask:rv_published; str:'Published')
|
|
);
|
|
type
|
|
toptionopt=record
|
|
mask : trtti_option;
|
|
str : string[10];
|
|
end;
|
|
const
|
|
voptionopt : array[0..ord(high(trtti_option))] of toptionopt=(
|
|
(mask:ro_methods; str:'Methods'),
|
|
(mask:ro_fields; str:'Fields'),
|
|
(mask:ro_properties; str:'Properties')
|
|
);
|
|
var
|
|
clause: string;
|
|
visibilities: trtti_visibilities;
|
|
first: boolean;
|
|
i, ro: integer;
|
|
begin
|
|
clause:='';
|
|
case trtti_clause(ppufile.getbyte) of
|
|
rtc_none: clause:='None';
|
|
rtc_inherit: clause:='Inherit';
|
|
rtc_explicit: clause:='Explicit';
|
|
end;
|
|
writeln([space,' Clause : ',clause]);
|
|
|
|
for ro:=0 to high(voptionopt) do
|
|
begin
|
|
ppufile.getset(tppuset1(visibilities));
|
|
if visibilities<>[] then
|
|
begin
|
|
write([space,' ',voptionopt[ro].str,' : ']);
|
|
first:=true;
|
|
for i:=0 to high(visopt) do
|
|
if visopt[i].mask in visibilities then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(visopt[i].str);
|
|
end;
|
|
if not first then
|
|
writeln;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure readprocimploptions(const space: string; out implprocoptions: timplprocoptions);
|
|
type
|
|
tpiopt=record
|
|
mask : timplprocoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
piopt : array[low(timplprocoption)..high(timplprocoption)] of tpiopt=(
|
|
(mask:pio_empty; str:'IsEmpty'),
|
|
(mask:pio_has_inlininginfo; str:'HasInliningInfo'),
|
|
(mask:pio_inline_not_possible; str:'InlineNotPossible'),
|
|
(mask:pio_nested_access; str:'NestedAccess'),
|
|
(mask:pio_thunk; str:'Thunk'),
|
|
(mask:pio_fastmath; str:'FastMath'),
|
|
(mask:pio_inline_forbidden; str:'InlineForbidden')
|
|
);
|
|
var
|
|
i: timplprocoption;
|
|
first: boolean;
|
|
begin
|
|
ppufile.getset(tppuset1(implprocoptions));
|
|
if implprocoptions<>[] then
|
|
begin
|
|
first:=true;
|
|
write([space,' Options : ']);
|
|
for i:=low(piopt) to high(piopt) do
|
|
begin
|
|
if i in implprocoptions then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(piopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
end;
|
|
|
|
procedure readarraydefoptions(ArrayDef: TPpuArrayDef);
|
|
{ type tarraydefoption is in unit symconst }
|
|
const
|
|
symopt : array[tarraydefoption] of string = (
|
|
{ ado_IsConvertedPointer } 'ConvertedPointer',
|
|
{ ado_IsDynamicArray } 'IsDynamicArray',
|
|
{ ado_IsVariant } 'IsVariant',
|
|
{ ado_IsConstructor } 'IsConstructor',
|
|
{ ado_IsArrayOfConst } 'ArrayOfConst',
|
|
{ ado_IsConstString } 'ConstString',
|
|
{ ado_IsBitPacked } 'BitPacked',
|
|
{ ado_IsVector } 'Vector',
|
|
{ ado_IsGeneric } 'Generic',
|
|
{ ado_OpenArray } 'OpenArray'
|
|
);
|
|
var
|
|
symoptions: tarraydefoptions;
|
|
i: tarraydefoption;
|
|
first: boolean;
|
|
begin
|
|
ppufile.getset(tppuset2(symoptions));
|
|
if symoptions<>[] then
|
|
begin
|
|
if ado_IsDynamicArray in symoptions then Include(ArrayDef.Options, aoDynamic);
|
|
first:=true;
|
|
for i:=Low(symopt) to high(symopt) do
|
|
if (i in symoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(symopt[i]);
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
|
|
(* options for properties
|
|
tpropertyoption=(ppo_none,
|
|
ppo_indexed,
|
|
ppo_defaultproperty,
|
|
ppo_stored,
|
|
ppo_hasparameters,
|
|
ppo_implements,
|
|
ppo_enumerator_current,
|
|
ppo_overrides,
|
|
ppo_dispid_write { no longer used }
|
|
);
|
|
tpropertyoptions=set of tpropertyoption;
|
|
*)
|
|
function readpropertyoptions:tpropertyoptions;
|
|
{ type tarraydefoption is in unit symconst }
|
|
type
|
|
tpropopt=record
|
|
mask : tpropertyoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
symopt : array[1..ord(high(tpropertyoption))] of tpropopt=(
|
|
(mask:ppo_indexed;str:'indexed'),
|
|
(mask:ppo_defaultproperty;str:'default'),
|
|
(mask:ppo_stored;str:'stored'),
|
|
(mask:ppo_hasparameters;str:'has parameters'),
|
|
(mask:ppo_implements;str:'implements'),
|
|
(mask:ppo_enumerator_current;str:'enumerator current'),
|
|
(mask:ppo_overrides;str:'overrides'),
|
|
(mask:ppo_dispid_write;str:'dispid write') { no longer used }
|
|
);
|
|
var
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset2(result));
|
|
if result<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to high(symopt) do
|
|
if (symopt[i].mask in result) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(symopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
end;
|
|
|
|
|
|
|
|
function readmanagementoperatoroptions(const space : string;const name : string):tmanagementoperators;
|
|
{ type is in unit symconst }
|
|
{ Management operator options
|
|
tmanagementoperator=(
|
|
mop_none,
|
|
mop_initialize,
|
|
mop_finalize,
|
|
mop_addref,
|
|
mop_copy);
|
|
}
|
|
type
|
|
tmopopt=record
|
|
mask : tmanagementoperator;
|
|
str : string[10];
|
|
end;
|
|
const
|
|
managementoperatoropt : array[1..ord(high(tmanagementoperator))] of tmopopt=(
|
|
(mask:mop_initialize;str:'initialize'),
|
|
(mask:mop_finalize;str:'finalize'),
|
|
(mask:mop_addref;str:'addref'),
|
|
(mask:mop_copy;str:'copy')
|
|
);
|
|
var
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset1(result));
|
|
if result<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1 to high(managementoperatoropt) do
|
|
if (managementoperatoropt[i].mask in result) then
|
|
begin
|
|
if first then
|
|
begin
|
|
write(space);
|
|
write(name);
|
|
write(': ');
|
|
first:=false;
|
|
end
|
|
else
|
|
write(', ');
|
|
write(managementoperatoropt[i].str);
|
|
end;
|
|
if not first then
|
|
writeln;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure readnodetree;
|
|
var
|
|
l : longint;
|
|
p : pointer;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
if space<>'' then
|
|
Writeln([space,'------ nodetree ------']);
|
|
if readentry=ibnodetree then
|
|
begin
|
|
l:=entrysize;
|
|
Writeln([space,'Tree size : ',l]);
|
|
{ Read data to prevent error that entry is not completly read }
|
|
getmem(p,l);
|
|
getdata(p^,l);
|
|
freemem(p);
|
|
end
|
|
else
|
|
begin
|
|
WriteError('!! ibnodetree not found');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure ReadCreatedObjTypes;
|
|
var
|
|
i,j,
|
|
len,
|
|
bssize: longint;
|
|
bs: pbyte;
|
|
begin
|
|
if ppufile.readentry<>ibcreatedobjtypes then
|
|
begin
|
|
WriteError('!! ibcreatedobjtypes entry not found');
|
|
ppufile.skipdata(ppufile.entrysize);
|
|
exit
|
|
end;
|
|
writeln;
|
|
writeln([space,'WPO info']);
|
|
writeln([space,'--------']);
|
|
|
|
len:=ppufile.getlongint;
|
|
writeln([space,'** Instantiated Object/Class types: ',len,' **']);
|
|
space:=space+' ';
|
|
for i:=0 to len-1 do
|
|
readderef(space);
|
|
setlength(space,length(space)-2);
|
|
|
|
len:=ppufile.getlongint;
|
|
writeln([space,'** Instantiated ClassRef types: ',len,' **']);
|
|
space:=space+' ';
|
|
for i:=0 to len-1 do
|
|
readderef(space);
|
|
setlength(space,length(space)-2);
|
|
|
|
len:=ppufile.getlongint;
|
|
writeln([space,'** Possibly instantiated ClassRef types : ',len,' **']);
|
|
space:=space+' ';
|
|
for i:=0 to len-1 do
|
|
readderef(space);
|
|
setlength(space,length(space)-2);
|
|
|
|
len:=ppufile.getlongint;
|
|
writeln([space,'** Class types with called virtual methods info : ',len,' **']);
|
|
space:=space+' ';
|
|
for i:=0 to len-1 do
|
|
begin
|
|
write([space,'Class def : ']);
|
|
readderef('');
|
|
write([space+' ','Called vmtentries : ']);
|
|
bssize:=ppufile.getlongint;
|
|
getmem(bs,bssize);
|
|
ppufile.readdata(bs^,bssize);
|
|
for j:=0 to bssize*8-1 do
|
|
if (((bs+j shr 3)^ shr (j and 7)) and 1) <> 0 then
|
|
write([j,', ']);
|
|
writeln;
|
|
freemem(bs);
|
|
end;
|
|
setlength(space,length(space)-2);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Read Symbols Part
|
|
****************************************************************************}
|
|
|
|
procedure readsymbols(const s:string; ParentDef: TPpuContainerDef = nil);
|
|
|
|
function _finddef(symdef: TPpuDef): TPpuDef;
|
|
begin
|
|
Result:=nil;
|
|
if symdef.Ref.IsCurUnit then
|
|
begin;
|
|
Result:=CurUnit.FindById(symdef.Ref.Id);
|
|
if (Result <> nil) and (Result.Ref.Id = symdef.Id) then
|
|
begin
|
|
Result.Name:=symdef.Name;
|
|
Result.FilePos:=symdef.FilePos;
|
|
end
|
|
else
|
|
Result:=nil;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
pguid = ^tguid;
|
|
tguid = packed record
|
|
D1: LongWord;
|
|
D2: Word;
|
|
D3: Word;
|
|
D4: array[0..7] of Byte;
|
|
end;
|
|
|
|
var
|
|
b : byte;
|
|
pc : pchar;
|
|
ch : dword;
|
|
startnewline : boolean;
|
|
i,j,len : longint;
|
|
prettyname, ss : ansistring;
|
|
ws: widestring;
|
|
guid : tguid;
|
|
realvalue : ppureal;
|
|
doublevalue : double;
|
|
singlevalue : single;
|
|
realstr : shortstring;
|
|
extended : TSplit80bitReal;
|
|
pw : pcompilerwidestring;
|
|
varoptions : tvaroptions;
|
|
propoptions : tpropertyoptions;
|
|
iexp: Tconstexprint;
|
|
def: TPpuDef;
|
|
constdef: TPpuConstDef absolute def;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
if space<>'' then
|
|
Writeln([space,'------ ',s,' ------']);
|
|
if readentry=ibstartsyms then
|
|
begin
|
|
Writeln([space,'Symtable count: ',getlongint]);
|
|
end
|
|
else
|
|
Writeln('!! ibstartsym not found');
|
|
repeat
|
|
def:=nil;
|
|
b:=readentry;
|
|
case b of
|
|
|
|
ibunitsym :
|
|
readcommonsym('Unit symbol ');
|
|
|
|
ibnamespacesym :
|
|
begin
|
|
readcommonsym('NameSpace symbol ');
|
|
write([space,' Hidden Unit : ']);
|
|
readderef('');
|
|
end;
|
|
|
|
iblabelsym :
|
|
readcommonsym('Label symbol ');
|
|
|
|
ibtypesym :
|
|
begin
|
|
def:=TPpuTypeRef.Create(nil);
|
|
readcommonsym('Type symbol ',def);
|
|
write([space,' Result Type : ']);
|
|
readderef('', def.Ref);
|
|
if _finddef(def) = nil then
|
|
def.Parent:=ParentDef;
|
|
prettyname:=getansistring;
|
|
if prettyname<>'' then
|
|
begin
|
|
write([space,' Pretty Name : ']);
|
|
Writeln(prettyname);
|
|
end;
|
|
end;
|
|
|
|
ibprocsym :
|
|
begin
|
|
def:=TPpuDef.Create(nil);
|
|
readcommonsym('Procedure symbol ', def);
|
|
len:=ppufile.getword;
|
|
for i:=1 to len do
|
|
begin
|
|
write([space,' Definition : ']);
|
|
readderef('', def.Ref);
|
|
_finddef(def);
|
|
end;
|
|
if def.GenericDummy then
|
|
begin
|
|
len:=ppufile.getword;
|
|
for i:=1 to len do
|
|
begin
|
|
write([space,' Gen Ovld : ']);
|
|
readderef('',def.Ref);
|
|
_finddef(def);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
ibconstsym :
|
|
begin
|
|
constdef:=TPpuConstDef.Create(ParentDef);
|
|
readcommonsym('Constant symbol ',constdef);
|
|
b:=getbyte;
|
|
case tconsttyp(b) of
|
|
constord :
|
|
begin
|
|
write ([space,' OrdinalType : ']);
|
|
readderef('',constdef.TypeRef);
|
|
iexp:=getexprint;
|
|
constdef.ConstType:=ctInt;
|
|
constdef.VInt:=iexp.svalue;
|
|
writeln([space,' Value : ',constexp.tostr(iexp)]);
|
|
end;
|
|
constpointer :
|
|
begin
|
|
write ([space,' PointerType : ']);
|
|
readderef('',constdef.TypeRef);
|
|
constdef.ConstType:=ctInt;
|
|
constdef.VInt:=int64(getptruint);
|
|
writeln([space,' Value : ',constdef.VInt])
|
|
end;
|
|
conststring,
|
|
constresourcestring :
|
|
begin
|
|
write ([space,' StringType : ']);
|
|
readderef('',constdef.TypeRef);
|
|
len:=getlongint;
|
|
getmem(pc,len+1);
|
|
getdata(pc^,len);
|
|
(pc+len)^:= #0;
|
|
writeln([space,' Length : ',len]);
|
|
writeln([space,' Value : "',pc,'"']);
|
|
constdef.ConstType:=ctStr;
|
|
SetString(constdef.VStr, pc, len);
|
|
constdef.VStr:=UTF8Encode(constdef.VStr);
|
|
freemem(pc,len+1);
|
|
end;
|
|
constreal :
|
|
begin
|
|
constdef.ConstType:=ctFloat;
|
|
write ([space,' RealType : ']);
|
|
readderef('',constdef.TypeRef);
|
|
write([space,' Value : ']);
|
|
if entryleft=sizeof(ppureal) then
|
|
begin
|
|
realvalue:=getrealsize(sizeof(ppureal));
|
|
constdef.VFloat:=realvalue;
|
|
system.str(realvalue,realstr);
|
|
writeln([realstr]);
|
|
end
|
|
else if entryleft=sizeof(double) then
|
|
begin
|
|
doublevalue:=getrealsize(sizeof(double));
|
|
constdef.VFloat:=doublevalue;
|
|
system.str(doublevalue,realstr);
|
|
writeln([realstr]);
|
|
end
|
|
else if entryleft=sizeof(single) then
|
|
begin
|
|
singlevalue:=getrealsize(sizeof(single));
|
|
constdef.VFloat:=singlevalue;
|
|
system.str(singlevalue,realstr);
|
|
writeln([realstr]);
|
|
end
|
|
else if entryleft=10 then
|
|
begin
|
|
getdata(extended,entryleft);
|
|
ss:=Real80bitToStr(extended,constdef.VFloat);
|
|
writeln(ss);
|
|
end
|
|
else
|
|
begin
|
|
realvalue:=0.0;
|
|
WriteError('Error reading real value');
|
|
end;
|
|
end;
|
|
constset :
|
|
begin
|
|
constdef.ConstType:=ctSet;
|
|
write ([space,' Set Type : ']);
|
|
readderef('',constdef.TypeRef);
|
|
for i:=1to 4 do
|
|
begin
|
|
write ([space,' Value : ']);
|
|
for j:=1to 8 do
|
|
begin
|
|
if j>1 then
|
|
write(',');
|
|
b:=getbyte;
|
|
if ppufile.change_endian then
|
|
b:=reverse_byte(b);
|
|
write(hexstr(b,2));
|
|
constdef.VSet[i*j-1]:=b;
|
|
end;
|
|
writeln;
|
|
end;
|
|
end;
|
|
constnil:
|
|
begin
|
|
write([space,' NIL pointer :']);
|
|
readderef('',constdef.TypeRef);
|
|
constdef.ConstType:=ctPtr;
|
|
constdef.VInt:=0;
|
|
end;
|
|
constwstring :
|
|
begin
|
|
initwidestring(pw);
|
|
setlengthwidestring(pw,getlongint);
|
|
if widecharsize=2 then
|
|
{ don't use getdata, because the compilerwidechars may have to
|
|
be byteswapped
|
|
}
|
|
begin
|
|
for i:=0 to pw^.len-1 do
|
|
pw^.data[i]:=ppufile.getword;
|
|
SetString(ws, PWideChar(pw^.data), pw^.len);
|
|
constdef.VStr:=UTF8Encode(ws);
|
|
constdef.ConstType:=ctStr;
|
|
end
|
|
else if widecharsize=4 then
|
|
begin
|
|
for i:=0 to pw^.len-1 do
|
|
pw^.data[i]:=cardinal(ppufile.getlongint);
|
|
end
|
|
else
|
|
begin
|
|
WriteError('Unsupported tcompilerwidechar size');
|
|
end;
|
|
Write([space,'Wide string type']);
|
|
startnewline:=true;
|
|
for i:=0 to pw^.len-1 do
|
|
begin
|
|
if startnewline then
|
|
begin
|
|
writeln;
|
|
write(space);
|
|
startnewline:=false;
|
|
end;
|
|
ch:=pw^.data[i];
|
|
if widecharsize=2 then
|
|
write(hexstr(ch,4))
|
|
else
|
|
write(hexstr(ch,8));
|
|
if ((i + 1) mod 8)= 0 then
|
|
startnewline:=true
|
|
else
|
|
if i <> pw^.len-1 then
|
|
write(', ');
|
|
end;
|
|
donewidestring(pw);
|
|
Writeln;
|
|
end;
|
|
constguid:
|
|
begin
|
|
write ([space,' IntfType : ']);
|
|
readderef('',constdef.TypeRef);
|
|
getdata(guid,sizeof(guid));
|
|
write ([space,' IID String: {',hexstr(guid.d1,8),'-',hexstr(guid.d2,4),'-',hexstr(guid.d3,4),'-']);
|
|
for i:=0 to 7 do
|
|
begin
|
|
write(hexstr(guid.d4[i],2));
|
|
if i=1 then write('-');
|
|
end;
|
|
writeln('}');
|
|
end
|
|
else
|
|
Writeln (['!! Invalid unit format : Invalid const type encountered: ',b]);
|
|
end;
|
|
end;
|
|
|
|
ibabsolutevarsym :
|
|
begin
|
|
def:=TPpuVarDef.Create(ParentDef);
|
|
readabstractvarsym('Absolute variable symbol ',varoptions,TPpuVarDef(def));
|
|
Write ([space,' Relocated to ']);
|
|
b:=getbyte;
|
|
case absolutetyp(b) of
|
|
tovar :
|
|
readpropaccesslist(space+' Sym : ');
|
|
toasm :
|
|
Writeln(['Assembler name : ',getstring]);
|
|
toaddr :
|
|
begin
|
|
Write(['Address : ',getpuint]);
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_i386 then
|
|
Write([' (Far: ',getbyte<>0,')']);
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_i8086 then
|
|
if getbyte<>0 then
|
|
Write([' (Far: TRUE, Segment=',getaword,')'])
|
|
else
|
|
Write([' (Far: FALSE)']);
|
|
Writeln;
|
|
end;
|
|
else
|
|
Writeln (['!! Invalid unit format : Invalid absolute type encountered: ',b]);
|
|
end;
|
|
end;
|
|
|
|
ibfieldvarsym :
|
|
begin
|
|
def:=TPpuFieldDef.Create(ParentDef);
|
|
readabstractvarsym('Field Variable symbol ',varoptions,TPpuVarDef(def));
|
|
writeln([space,' Address : ',getasizeint]);
|
|
if vo_has_mangledname in varoptions then
|
|
writeln([space,' Mangled name : ',getstring]);
|
|
end;
|
|
|
|
ibstaticvarsym :
|
|
begin
|
|
def:=TPpuVarDef.Create(ParentDef);
|
|
readabstractvarsym('Global Variable symbol ',varoptions,TPpuVarDef(def));
|
|
write ([space,' DefaultConst : ']);
|
|
readderef('');
|
|
if (vo_has_mangledname in varoptions) then
|
|
writeln([space,'Mangledname : ',readsymstr(ppufile)]);
|
|
if vo_has_section in varoptions then
|
|
writeln(['Section name:',ppufile.getansistring]);
|
|
write ([space,' FieldVarSymDeref: ']);
|
|
readderef('');
|
|
end;
|
|
|
|
iblocalvarsym :
|
|
begin
|
|
readabstractvarsym('Local Variable symbol ',varoptions);
|
|
write ([space,' DefaultConst : ']);
|
|
readderef('');
|
|
end;
|
|
|
|
ibparavarsym :
|
|
begin
|
|
def:=TPpuParamDef.Create(ParentDef);
|
|
readabstractvarsym('Parameter Variable symbol ',varoptions,TPpuVarDef(def));
|
|
write ([space,' DefaultConst : ']);
|
|
readderef('',TPpuParamDef(def).DefaultValue);
|
|
writeln([space,' ParaNr : ',getword]);
|
|
writeln([space,' Univ : ',getboolean]);
|
|
writeln([space,' VarState : ',getbyte]);
|
|
writeln([space,' Refs : ',getbyte]);
|
|
if (vo_has_explicit_paraloc in varoptions) then
|
|
begin
|
|
readcgpara(space+' ');
|
|
end;
|
|
end;
|
|
|
|
ibenumsym :
|
|
begin
|
|
def:=TPpuConstDef.Create(nil);
|
|
readcommonsym('Enumeration symbol ',def);
|
|
write ([space,' Definition : ']);
|
|
readderef('');
|
|
TPpuConstDef(def).ConstType:=ctInt;
|
|
TPpuConstDef(def).VInt:=getlongint;
|
|
writeln([space,' Value : ',TPpuConstDef(def).VInt]);
|
|
if (ParentDef <> nil) and (ParentDef.DefType = dtEnum) then
|
|
def.Parent:=ParentDef;
|
|
end;
|
|
|
|
ibsyssym :
|
|
begin
|
|
readcommonsym('Internal system symbol ');
|
|
writeln([space,' Internal Nr : ',getlongint]);
|
|
end;
|
|
|
|
ibmacrosym :
|
|
begin
|
|
readcommonsym('Macro symbol ');
|
|
writeln([space,' Defined: ',getboolean]);
|
|
writeln([space,' Compiler var: ',getboolean]);
|
|
len:=getlongint;
|
|
writeln([space,' Value length: ',len]);
|
|
if len > 0 then
|
|
begin
|
|
getmem(pc,len+1);
|
|
getdata(pc^,len);
|
|
(pc+len)^:= #0;
|
|
writeln([space,' Value: "',pc,'"']);
|
|
freemem(pc,len+1);
|
|
end;
|
|
end;
|
|
|
|
ibpropertysym :
|
|
begin
|
|
def:=TPpuPropDef.Create(ParentDef);
|
|
readcommonsym('Property ',def);
|
|
write ([space,' Prop Options : ']);
|
|
propoptions:=readpropertyoptions;
|
|
if ppo_overrides in propoptions then
|
|
begin
|
|
write ([space,' OverrideProp : ']);
|
|
readderef('');
|
|
end;
|
|
if ppo_defaultproperty in propoptions then
|
|
Include(TPpuPropDef(def).Options, poDefault);
|
|
write ([space,' Prop Type : ']);
|
|
readderef('',TPpuPropDef(def).PropType);
|
|
writeln([space,' Index : ',getlongint]);
|
|
writeln([space,' Default : ',getlongint]);
|
|
write ([space,' Index Type : ']);
|
|
readderef('');
|
|
{ palt_none }
|
|
write ([space,' Noneaccess : ']);
|
|
readpropaccesslist('');
|
|
write ([space,' Readaccess : ']);
|
|
readpropaccesslist(space+' Sym: ',TPpuPropDef(def).Getter);
|
|
write ([space,' Writeaccess : ']);
|
|
readpropaccesslist(space+' Sym: ',TPpuPropDef(def).Setter);
|
|
write ([space,' Storedaccess : ']);
|
|
readpropaccesslist(space+' Sym: ');
|
|
if [ppo_hasparameters,ppo_overrides]*propoptions=[ppo_hasparameters] then
|
|
begin
|
|
space:=' '+space;
|
|
readsymtable('parast',TPpuPropDef(def));
|
|
delete(space,1,4);
|
|
end;
|
|
end;
|
|
|
|
iberror :
|
|
begin
|
|
WriteError('!! Error in PPU');
|
|
exit;
|
|
end;
|
|
|
|
ibendsyms :
|
|
break;
|
|
|
|
else
|
|
begin
|
|
WriteError('!! Skipping unsupported PPU Entry in Symbols: '+IntToStr(b));
|
|
end;
|
|
end;
|
|
if assigned(def) then
|
|
readsymsubentries(def);
|
|
if (def <> nil) and (def.Parent = nil) then
|
|
def.Free;
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
until false;
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
Read defintions Part
|
|
****************************************************************************}
|
|
|
|
procedure readdefinitions(const s:string; ParentDef: TPpuContainerDef);
|
|
{ type tordtype is in symconst unit }
|
|
{
|
|
uvoid,
|
|
u8bit,u16bit,u32bit,u64bit,u128bit,
|
|
s8bit,s16bit,s32bit,s64bit,s128bit,
|
|
bool8bit,bool16bit,bool32bit,bool64bit,
|
|
uchar,uwidechar,scurrency,customint
|
|
); }
|
|
|
|
{ type tobjecttyp is in symconst unit }
|
|
{ type tvarianttype is in symconst unit }
|
|
{ type thelpertype is in symconst unit }
|
|
var
|
|
b : byte;
|
|
otb : byte; { Object Type byte, needed later again }
|
|
l,j,tokenbufsize : longint;
|
|
tokenbuf : pbyte;
|
|
calloption : tproccalloption;
|
|
procoptions : tprocoptions;
|
|
implprocoptions: timplprocoptions;
|
|
defoptions: tdefoptions;
|
|
iexpr: Tconstexprint;
|
|
def: TPpuDef;
|
|
objdef: TPpuObjectDef absolute def;
|
|
arrdef: TPpuArrayDef absolute def;
|
|
enumdef: TPpuEnumDef absolute def;
|
|
setdef: TPpuSetDef absolute def;
|
|
orddef: TPpuOrdDef absolute def;
|
|
floatdef: TPpuFloatDef absolute def;
|
|
strdef: TPpuStringDef absolute def;
|
|
filedef: TPpuFileDef absolute def;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
if space<>'' then
|
|
Writeln([space,'------ ',s,' ------']);
|
|
if readentry<>ibstartdefs then
|
|
Writeln('!! ibstartdefs not found');
|
|
repeat
|
|
def:=nil;
|
|
b:=readentry;
|
|
case b of
|
|
|
|
ibpointerdef :
|
|
begin
|
|
def:=TPpuPointerDef.Create(ParentDef);
|
|
readcommondef('Pointer definition',defoptions,def);
|
|
write ([space,' Pointed Type : ']);
|
|
readderef('',TPpuPointerDef(def).Ptr);
|
|
writeln([space,' Has Pointer Math : ',(getbyte<>0)]);
|
|
if tsystemcpu(ppufile.header.common.cpu) in [cpu_i8086,cpu_i386,cpu_x86_64] then
|
|
begin
|
|
write([space,' X86 Pointer Type : ']);
|
|
b:=getbyte;
|
|
case tx86pointertyp(b) of
|
|
x86pt_near: writeln('Near');
|
|
x86pt_near_cs: writeln('Near ''CS''');
|
|
x86pt_near_ds: writeln('Near ''DS''');
|
|
x86pt_near_ss: writeln('Near ''SS''');
|
|
x86pt_near_es: writeln('Near ''ES''');
|
|
x86pt_near_fs: writeln('Near ''FS''');
|
|
x86pt_near_gs: writeln('Near ''GS''');
|
|
x86pt_far: writeln('Far');
|
|
x86pt_huge: writeln('Huge');
|
|
else
|
|
WriteWarning('Invalid x86 pointer type: ' + IntToStr(b));
|
|
end;
|
|
end;
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_wasm32 then
|
|
writeln([space,' WASM externref : ',(getbyte<>0)]);
|
|
end;
|
|
|
|
iborddef :
|
|
begin
|
|
orddef:=TPpuOrdDef.Create(ParentDef);
|
|
readcommondef('Ordinal definition',defoptions,orddef);
|
|
write ([space,' Base type : ']);
|
|
b:=getbyte;
|
|
case tordtype(b) of
|
|
uvoid:
|
|
begin
|
|
writeln('uvoid');
|
|
orddef.OrdType:=otVoid;
|
|
end;
|
|
u8bit:
|
|
begin
|
|
writeln('u8bit');
|
|
orddef.OrdType:=otUInt;
|
|
orddef.Size:=1;
|
|
end;
|
|
u16bit:
|
|
begin
|
|
writeln('u16bit');
|
|
orddef.OrdType:=otUInt;
|
|
orddef.Size:=2;
|
|
end;
|
|
u32bit:
|
|
begin
|
|
writeln('u32bit');
|
|
orddef.OrdType:=otUInt;
|
|
orddef.Size:=4;
|
|
end;
|
|
u64bit:
|
|
begin
|
|
writeln('u64bit');
|
|
orddef.OrdType:=otUInt;
|
|
orddef.Size:=8;
|
|
end;
|
|
u128bit:
|
|
begin
|
|
writeln('u128bit');
|
|
orddef.OrdType:=otUInt;
|
|
orddef.Size:=16;
|
|
end;
|
|
s8bit:
|
|
begin
|
|
writeln('s8bit');
|
|
orddef.OrdType:=otSInt;
|
|
orddef.Size:=1;
|
|
end;
|
|
s16bit:
|
|
begin
|
|
writeln('s16bit');
|
|
orddef.OrdType:=otSInt;
|
|
orddef.Size:=2;
|
|
end;
|
|
s32bit:
|
|
begin
|
|
writeln('s32bit');
|
|
orddef.OrdType:=otSInt;
|
|
orddef.Size:=4;
|
|
end;
|
|
s64bit:
|
|
begin
|
|
writeln('s64bit');
|
|
orddef.OrdType:=otSInt;
|
|
orddef.Size:=8;
|
|
end;
|
|
s128bit:
|
|
begin
|
|
writeln('s128bit');
|
|
orddef.OrdType:=otSInt;
|
|
orddef.Size:=16;
|
|
end;
|
|
pasbool1:
|
|
begin
|
|
writeln('pasbool1');
|
|
orddef.OrdType:=otPasBool;
|
|
orddef.Size:=1;
|
|
end;
|
|
pasbool8:
|
|
begin
|
|
writeln('pasbool8');
|
|
orddef.OrdType:=otPasBool;
|
|
orddef.Size:=1;
|
|
end;
|
|
pasbool16:
|
|
begin
|
|
writeln('pasbool16');
|
|
orddef.OrdType:=otPasBool;
|
|
orddef.Size:=2;
|
|
end;
|
|
pasbool32:
|
|
begin
|
|
writeln('pasbool32');
|
|
orddef.OrdType:=otPasBool;
|
|
orddef.Size:=4;
|
|
end;
|
|
pasbool64:
|
|
begin
|
|
writeln('pasbool64');
|
|
orddef.OrdType:=otPasBool;
|
|
orddef.Size:=8;
|
|
end;
|
|
bool8bit:
|
|
begin
|
|
writeln('bool8bit');
|
|
orddef.OrdType:=otBool;
|
|
orddef.Size:=1;
|
|
end;
|
|
bool16bit:
|
|
begin
|
|
writeln('bool16bit');
|
|
orddef.OrdType:=otBool;
|
|
orddef.Size:=2;
|
|
end;
|
|
bool32bit:
|
|
begin
|
|
writeln('bool32bit');
|
|
orddef.OrdType:=otBool;
|
|
orddef.Size:=4;
|
|
end;
|
|
bool64bit:
|
|
begin
|
|
writeln('bool64bit');
|
|
orddef.OrdType:=otBool;
|
|
orddef.Size:=8;
|
|
end;
|
|
uchar:
|
|
begin
|
|
writeln('uchar');
|
|
orddef.OrdType:=otChar;
|
|
orddef.Size:=1;
|
|
end;
|
|
uwidechar:
|
|
begin
|
|
writeln('uwidechar');
|
|
orddef.OrdType:=otChar;
|
|
orddef.Size:=2;
|
|
end;
|
|
scurrency:
|
|
begin
|
|
writeln('scurrency');
|
|
orddef.OrdType:=otCurrency;
|
|
orddef.Size:=8;
|
|
end;
|
|
customint:
|
|
begin
|
|
writeln('customint');
|
|
orddef.OrdType:=otSint;
|
|
orddef.Size:=sizeof(ASizeInt);
|
|
end
|
|
else
|
|
WriteWarning('Invalid base type: ' + IntToStr(b));
|
|
end;
|
|
iexpr:=getexprint;
|
|
orddef.RangeLow:=iexpr.svalue;
|
|
write([space,' Range : ',constexp.tostr(iexpr)]);
|
|
iexpr:=getexprint;
|
|
orddef.RangeHigh:=iexpr.svalue;
|
|
writeln([' to ',constexp.tostr(iexpr)]);
|
|
end;
|
|
|
|
ibfloatdef :
|
|
begin
|
|
floatdef:=TPpuFloatDef.Create(ParentDef);
|
|
readcommondef('Float definition',defoptions,floatdef);
|
|
write ([space,' Float type : ']);
|
|
b:=getbyte;
|
|
case b of
|
|
ftSingle:
|
|
begin
|
|
writeln('Single');
|
|
floatdef.FloatType:=pftSingle;
|
|
end;
|
|
ftDouble:
|
|
begin
|
|
writeln('Double');
|
|
floatdef.FloatType:=pftDouble;
|
|
end;
|
|
ftExtended:
|
|
begin
|
|
writeln('Extended');
|
|
floatdef.FloatType:=pftExtended;
|
|
end;
|
|
ftComp:
|
|
begin
|
|
writeln('Comp');
|
|
floatdef.FloatType:=pftComp;
|
|
end;
|
|
ftCurr:
|
|
begin
|
|
writeln('Currency');
|
|
floatdef.FloatType:=pftCurrency;
|
|
end;
|
|
ftFloat128:
|
|
begin
|
|
writeln('Float128');
|
|
floatdef.FloatType:=pftFloat128;
|
|
end;
|
|
else
|
|
WriteWarning('Invalid float type: ' + IntToStr(b));
|
|
end;
|
|
end;
|
|
|
|
ibarraydef :
|
|
begin
|
|
arrdef:=TPpuArrayDef.Create(ParentDef);
|
|
readcommondef('Array definition',defoptions,arrdef);
|
|
write ([space,' Element type : ']);
|
|
readderef('',arrdef.ElType);
|
|
write ([space,' Range Type : ']);
|
|
readderef('',arrdef.RangeType);
|
|
arrdef.RangeLow:=getasizeint;
|
|
arrdef.RangeHigh:=getasizeint;
|
|
writeln([space,' Range : ',arrdef.RangeLow,' to ',arrdef.RangeHigh]);
|
|
write ([space,' Options : ']);
|
|
readarraydefoptions(arrdef);
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_i8086 then
|
|
writeln([space,' Huge : ',(getbyte<>0)]);
|
|
readsymtable('symbols', arrdef);
|
|
end;
|
|
|
|
ibprocdef :
|
|
begin
|
|
def:=TPpuProcDef.Create(ParentDef);
|
|
readcommondef('Procedure definition',defoptions,def);
|
|
read_abstract_proc_def(calloption,procoptions,TPpuProcDef(def));
|
|
if (po_has_mangledname in procoptions) then
|
|
writeln([space,' Mangled name : ',readsymstr(ppufile)]);
|
|
writeln([space,' Number : ',getword]);
|
|
writeln([space,' Level : ',getbyte]);
|
|
write ([space,' Class : ']);
|
|
readderef('');
|
|
write ([space,' Procsym : ']);
|
|
readderef('', def.Ref);
|
|
write ([space,' File Pos : ']);
|
|
readposinfo(def);
|
|
write ([space,' Visibility : ']);
|
|
readvisibility(def);
|
|
write ([space,' SymOptions : ']);
|
|
readsymoptions(space+' ');
|
|
if (po_has_importdll in procoptions) then
|
|
writeln([space,' Import DLL : ',getstring]);
|
|
if (po_has_importname in procoptions) then
|
|
writeln([space,' Import Name : ',getstring]);
|
|
writeln([space,' Import Nr : ',getword]);
|
|
if (po_msgint in procoptions) then
|
|
writeln([space,' MsgInt : ',getlongint]);
|
|
if (po_msgstr in procoptions) then
|
|
writeln([space,' MsgStr : ',getstring]);
|
|
if (po_dispid in procoptions) then
|
|
writeln([space,' DispID: ',ppufile.getlongint]);
|
|
readprocimploptions(space,implprocoptions);
|
|
if (pio_has_inlininginfo in implprocoptions) then
|
|
begin
|
|
write ([space,' FuncretSym : ']);
|
|
readderef('');
|
|
readprocinfooptions(space);
|
|
end;
|
|
b:=ppufile.getbyte;
|
|
if b<>0 then
|
|
begin
|
|
write ([space,' Alias names : ']);
|
|
for j:=1 to b do
|
|
begin
|
|
write(ppufile.getstring);
|
|
if j<b then
|
|
write(', ');
|
|
end;
|
|
writeln;
|
|
end;
|
|
tokenbufsize:=ppufile.getlongint;
|
|
if tokenbufsize<>0 then
|
|
begin
|
|
space:=space + ' ';
|
|
write ([space,'Declaration token buffer : size = ',tokenbufsize]);
|
|
tokenbuf:=allocmem(tokenbufsize);
|
|
ppufile.getdata(tokenbuf^,tokenbufsize);
|
|
displaytokenbuffer(tokenbuf,tokenbufsize);
|
|
freemem(tokenbuf);
|
|
delete(space,1,4);
|
|
end;
|
|
if po_syscall_has_libsym in procoptions then
|
|
begin
|
|
{ library symbol for AmigaOS/MorphOS/AROS }
|
|
write ([space,' Library symbol : ']);
|
|
readderef('');
|
|
end;
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
space:=' '+space;
|
|
{ parast }
|
|
readsymtable('parast', TPpuProcDef(def));
|
|
{ localst }
|
|
if (pio_has_inlininginfo in implprocoptions) then
|
|
readsymtable('inline localst')
|
|
else if (df_generic in defoptions) then
|
|
readsymtable('generic localst');
|
|
if (pio_has_inlininginfo in implprocoptions) then
|
|
readnodetree;
|
|
delete(space,1,4);
|
|
end;
|
|
|
|
ibprocvardef :
|
|
begin
|
|
def:=TPpuProcTypeDef.Create(ParentDef);
|
|
readcommondef('Procedural type (ProcVar) definition',defoptions,def);
|
|
read_abstract_proc_def(calloption,procoptions, TPpuProcDef(def));
|
|
writeln([space,' Symtable level :',ppufile.getbyte]);
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_jvm then
|
|
readderef('');
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
space:=' '+space;
|
|
{ parast }
|
|
readsymtable('parast',TPpuProcDef(def));
|
|
delete(space,1,4);
|
|
end;
|
|
|
|
ibshortstringdef :
|
|
begin
|
|
strdef:=TPpuStringDef.Create(ParentDef);
|
|
strdef.StrType:=stShort;
|
|
readcommondef('ShortString definition',defoptions,strdef);
|
|
strdef.Len:=getbyte;
|
|
writeln([space,' Length : ',strdef.Len]);
|
|
end;
|
|
|
|
ibwidestringdef :
|
|
begin
|
|
strdef:=TPpuStringDef.Create(ParentDef);
|
|
strdef.StrType:=stWide;
|
|
readcommondef('WideString definition',defoptions,strdef);
|
|
strdef.Len:=getasizeint;
|
|
writeln([space,' Length : ',strdef.Len]);
|
|
end;
|
|
|
|
ibunicodestringdef :
|
|
begin
|
|
strdef:=TPpuStringDef.Create(ParentDef);
|
|
strdef.StrType:=stUnicode;
|
|
readcommondef('UnicodeString definition',defoptions,strdef);
|
|
strdef.Len:=getasizeint;
|
|
writeln([space,' Length : ',strdef.Len]);
|
|
writeln([space,' Encoding : ',getword]);
|
|
end;
|
|
|
|
ibansistringdef :
|
|
begin
|
|
strdef:=TPpuStringDef.Create(ParentDef);
|
|
strdef.StrType:=stAnsi;
|
|
readcommondef('AnsiString definition',defoptions,strdef);
|
|
strdef.Len:=getasizeint;
|
|
writeln([space,' Length : ',strdef.Len]);
|
|
writeln([space,' Encoding : ',getword]);
|
|
end;
|
|
|
|
iblongstringdef :
|
|
begin
|
|
strdef:=TPpuStringDef.Create(ParentDef);
|
|
strdef.StrType:=stLong;
|
|
readcommondef('Longstring definition',defoptions,strdef);
|
|
strdef.Len:=getasizeint;
|
|
writeln([space,' Length : ',strdef.Len]);
|
|
end;
|
|
|
|
ibrecorddef :
|
|
begin
|
|
objdef:=TPpuRecordDef.Create(ParentDef);
|
|
readcommondef('Record definition',defoptions, objdef);
|
|
def.Name:=getstring;
|
|
writeln([space,' Name of Record : ',objdef.Name]);
|
|
writeln([space,' Import lib/pkg : ',getstring]);
|
|
write ([space,' Options : ']);
|
|
readobjectdefoptions(objdef);
|
|
writeln([space,' Extended RTTI : ']);
|
|
readextendedrtti;
|
|
if (df_copied_def in defoptions) then
|
|
begin
|
|
Include(TPpuRecordDef(def).Options, ooCopied);
|
|
write([space,' Copied from : ']);
|
|
readderef('',objdef.Ancestor);
|
|
end
|
|
else
|
|
begin
|
|
writeln([space,' FieldAlign : ',shortint(getbyte)]);
|
|
writeln([space,' RecordAlign : ',shortint(getbyte)]);
|
|
writeln([space,' PadAlign : ',shortint(getbyte)]);
|
|
writeln([space,'UseFieldAlignment : ',shortint(getbyte)]);
|
|
writeln([space,' RecordAlignMin : ',shortint(getbyte)]);
|
|
objdef.Size:=getasizeint;
|
|
writeln([space,' DataSize : ',objdef.Size]);
|
|
writeln([space,' PaddingSize : ',getword]);
|
|
readmanagementoperatoroptions(space,'Management operators');
|
|
end;
|
|
{read the record definitions and symbols}
|
|
if not(df_copied_def in current_defoptions) then
|
|
begin
|
|
space:=' '+space;
|
|
readrecordsymtable('fields',TPpuRecordDef(def));
|
|
Delete(space,1,4);
|
|
end;
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
end;
|
|
|
|
ibobjectdef :
|
|
begin
|
|
objdef:=TPpuObjectDef.Create(ParentDef);
|
|
readcommondef('Object/Class definition',defoptions,objdef);
|
|
objdef.Name:=getstring;
|
|
writeln([space,' Name of Class : ',objdef.Name]);
|
|
writeln([space,' Import lib/pkg : ',getstring]);
|
|
write ([space,' Options : ']);
|
|
readobjectdefoptions(objdef);
|
|
writeln([space,' Extended RTTI : ']);
|
|
readextendedrtti;
|
|
otb:=getbyte;
|
|
write ([space,' Type : ']);
|
|
case tobjecttyp(otb) of
|
|
odt_class : writeln('class');
|
|
odt_object : writeln('object');
|
|
odt_interfacecom : writeln('interfacecom');
|
|
odt_interfacecorba : writeln('interfacecorba');
|
|
odt_cppclass : writeln('cppclass');
|
|
odt_dispinterface : writeln('dispinterface');
|
|
odt_objcclass : writeln('objcclass');
|
|
odt_objcprotocol : writeln('objcprotocol');
|
|
odt_helper : writeln('helper');
|
|
odt_objccategory : writeln('objccategory');
|
|
odt_javaclass : writeln('Java class');
|
|
odt_interfacejava : writeln('Java interface');
|
|
else WriteWarning('Invalid object type: ' + IntToStr(b));
|
|
end;
|
|
case tobjecttyp(otb) of
|
|
odt_class, odt_cppclass, odt_objcclass, odt_javaclass:
|
|
objdef.ObjType:=otClass;
|
|
odt_object:
|
|
objdef.ObjType:=otObject;
|
|
odt_interfacecom, odt_interfacecorba, odt_interfacejava, odt_dispinterface:
|
|
objdef.ObjType:=otInterface;
|
|
odt_helper:
|
|
objdef.ObjType:=otHelper;
|
|
end;
|
|
b:=getbyte;
|
|
write ([space,' Helper Type : ']);
|
|
case thelpertype(b) of
|
|
ht_none : writeln('none');
|
|
ht_class : writeln('class helper');
|
|
ht_record : writeln('record helper');
|
|
ht_type : writeln('type helper');
|
|
else WriteWarning('Invalid helper type: ' + IntToStr(b));
|
|
end;
|
|
writeln([space,' External name : ',getstring]);
|
|
objdef.Size:=getasizeint;
|
|
writeln([space,' DataSize : ',objdef.Size]);
|
|
writeln([space,' PaddingSize : ',getword]);
|
|
writeln([space,' FieldAlign : ',shortint(getbyte)]);
|
|
writeln([space,' RecordAlign : ',shortint(getbyte)]);
|
|
writeln([space,' RecordAlignMin : ',shortint(getbyte)]);
|
|
write ([space, ' VmtField : ']);
|
|
readderef('',nil);
|
|
write ([space, ' Ancestor Class : ']);
|
|
readderef('',objdef.Ancestor);
|
|
|
|
if tobjecttyp(otb) in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
|
|
begin
|
|
{ IIDGUID }
|
|
for j:=1to 16 do
|
|
getbyte;
|
|
objdef.IID:=getstring;
|
|
writeln([space,' IID String : ',objdef.IID]);
|
|
end;
|
|
|
|
l:=getlongint;
|
|
if l > 0 then
|
|
objdef.Options:=objdef.Options + [ooAbstractMethods];
|
|
writeln([space,' Abstract methods : ',l]);
|
|
|
|
if tobjecttyp(otb)=odt_helper then
|
|
begin
|
|
write([space,' Helper parent : ']);
|
|
readderef('',objdef.HelperParent);
|
|
end;
|
|
|
|
l:=getlongint;
|
|
writeln([space,' VMT entries: ',l]);
|
|
for j:=1 to l do
|
|
begin
|
|
write([space,' ']);
|
|
readderef('');
|
|
write([space,' Visibility: ']);
|
|
readvisibility;
|
|
end;
|
|
|
|
if tobjecttyp(otb) in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
|
|
begin
|
|
l:=getlongint;
|
|
writeln([space,' Impl Intf Count : ',l]);
|
|
for j:=1 to l do
|
|
begin
|
|
write ([space,' - Definition : ']);
|
|
readderef('');
|
|
write ([space,' - Getter Def : ']);
|
|
readderef('');
|
|
writeln([space,' IOffset : ',getlongint]);
|
|
writeln([space,' Entry type : ',IntfEntryType2Str(getbyte)]);
|
|
end;
|
|
end;
|
|
|
|
if df_copied_def in current_defoptions then
|
|
begin
|
|
Include(objdef.Options, ooCopied);
|
|
writeln(' Copy of def: ');
|
|
readderef('',objdef.Ancestor);
|
|
end
|
|
else
|
|
begin
|
|
{read the record definitions and symbols}
|
|
space:=' '+space;
|
|
readrecordsymtable('fields',objdef);
|
|
Delete(space,1,4);
|
|
end;
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
end;
|
|
|
|
ibfiledef :
|
|
begin
|
|
filedef:=TPpuFileDef.Create(ParentDef);
|
|
ReadCommonDef('File definition',defoptions,filedef);
|
|
write ([space,' Type : ']);
|
|
case getbyte of
|
|
0 : begin
|
|
writeln('Text');
|
|
filedef.FileType:=ftText;
|
|
end;
|
|
1 : begin
|
|
writeln('Typed');
|
|
filedef.FileType:=ftTyped;
|
|
write ([space,' File of Type : ']);
|
|
readderef('',filedef.TypeRef);
|
|
end;
|
|
2 : begin
|
|
writeln('Untyped');
|
|
filedef.FileType:=ftUntyped;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
ibformaldef :
|
|
begin
|
|
def:=TPpuFormalDef.Create(ParentDef);
|
|
readcommondef('Generic definition (void-typ)',defoptions,def);
|
|
TPpuFormalDef(def).IsTyped:=(getbyte<>0);
|
|
writeln([space,' Is Typed : ',TPpuFormalDef(def).IsTyped]);
|
|
end;
|
|
|
|
ibundefineddef :
|
|
begin
|
|
def:=TPpuUndefinedDef.Create(ParentDef);
|
|
readcommondef('Undefined definition (generic parameter)',defoptions,def);
|
|
end;
|
|
|
|
ibenumdef :
|
|
begin
|
|
enumdef:=TPpuEnumDef.Create(ParentDef);
|
|
readcommondef('Enumeration type definition',defoptions,enumdef);
|
|
enumdef.ElLow:=getaint;
|
|
writeln([space,' Smallest element : ',enumdef.ElLow]);
|
|
enumdef.ElHigh:=getaint;
|
|
writeln([space,' Largest element : ',enumdef.ElHigh]);
|
|
enumdef.Size:=byte(getaint);
|
|
writeln([space,' Size : ',enumdef.Size]);
|
|
if df_copied_def in defoptions then
|
|
begin
|
|
write([space,'Base enumeration type : ']);
|
|
readderef('',enumdef.CopyFrom);
|
|
end
|
|
else
|
|
begin
|
|
space:=' '+space;
|
|
readsymtable('elements',enumdef);
|
|
delete(space,1,4);
|
|
end;
|
|
if tsystemcpu(ppufile.header.common.cpu)=cpu_jvm then
|
|
begin
|
|
write([space,' Class def : ']);
|
|
readderef('');
|
|
end;
|
|
end;
|
|
|
|
ibclassrefdef :
|
|
begin
|
|
def:=TPpuClassRefDef.Create(ParentDef);
|
|
readcommondef('Class reference definition',defoptions,def);
|
|
write ([space,' Pointed Type : ']);
|
|
readderef('',TPpuClassRefDef(def).ClassRef);
|
|
end;
|
|
|
|
ibsetdef :
|
|
begin
|
|
setdef:=TPpuSetDef.Create(ParentDef);
|
|
readcommondef('Set definition',defoptions,setdef);
|
|
write ([space,' Element type : ']);
|
|
readderef('',setdef.ElType);
|
|
setdef.Size:=getasizeint;
|
|
writeln([space,' Size : ',setdef.Size]);
|
|
setdef.SetBase:=getasizeint;
|
|
writeln([space,' Set Base : ',setdef.SetBase]);
|
|
setdef.SetMax:=getasizeint;
|
|
writeln([space,' Set Max : ',setdef.SetMax]);
|
|
end;
|
|
|
|
ibvariantdef :
|
|
begin
|
|
def:=TPpuVariantDef.Create(ParentDef);
|
|
readcommondef('Variant definition',defoptions,def);
|
|
write ([space,' Varianttype : ']);
|
|
b:=getbyte;
|
|
case tvarianttype(b) of
|
|
vt_normalvariant :
|
|
writeln('Normal');
|
|
vt_olevariant :
|
|
begin
|
|
TPpuVariantDef(def).IsOLE:=True;
|
|
writeln('OLE');
|
|
end
|
|
else
|
|
WriteWarning('Invalid varianttype: ' + IntToStr(b));
|
|
end;
|
|
end;
|
|
|
|
iberror :
|
|
begin
|
|
WriteError('!! Error in PPU');
|
|
exit;
|
|
end;
|
|
|
|
ibenddefs :
|
|
break;
|
|
|
|
else
|
|
begin
|
|
WriteError('!! Skipping unsupported PPU Entry in definitions: '+IntToStr(b));
|
|
end;
|
|
end;
|
|
if assigned(def) then
|
|
readdefsubentries(def);
|
|
if (def <> nil) and (def.Parent = nil) then
|
|
def.Free;
|
|
if not EndOfEntry then
|
|
HasMoreInfos;
|
|
until false;
|
|
end;
|
|
end;
|
|
|
|
procedure readmoduleoptions(space : string);
|
|
type
|
|
{ tmoduleoption type is in unit fmodule }
|
|
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;
|
|
tmoduleopt=record
|
|
mask : tmoduleoption;
|
|
str : string[30];
|
|
end;
|
|
const
|
|
moduleopts=ord(high(tmoduleoption));
|
|
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')
|
|
);
|
|
var
|
|
moduleoptions : tmoduleoptions;
|
|
i : longint;
|
|
first : boolean;
|
|
begin
|
|
ppufile.getset(tppuset1(moduleoptions));
|
|
if moduleoptions<>[] then
|
|
begin
|
|
first:=true;
|
|
for i:=1to moduleopts do
|
|
if (moduleopt[i].mask in moduleoptions) then
|
|
begin
|
|
if first then
|
|
first:=false
|
|
else
|
|
write(', ');
|
|
write(moduleopt[i].str);
|
|
end;
|
|
end;
|
|
writeln;
|
|
if mo_has_deprecated_msg in moduleoptions then
|
|
writeln([space,'Deprecated : ', ppufile.getstring]);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Read General Part
|
|
****************************************************************************}
|
|
|
|
procedure readinterface(silent : boolean);
|
|
var
|
|
b : byte;
|
|
sourcenumber, i : longint;
|
|
feature : tfeature;
|
|
features : tfeatures;
|
|
s : string;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
repeat
|
|
b:=readentry;
|
|
case b of
|
|
|
|
ibmodulename :
|
|
begin
|
|
CurUnit.Name:=getstring;
|
|
if not silent then
|
|
Writeln(['Module Name: ',CurUnit.Name]);
|
|
end;
|
|
|
|
ibfeatures :
|
|
begin
|
|
getset(tppuset4(features));
|
|
Writeln('Features: ');
|
|
for feature:=low(tfeatures) to high(tfeature) do
|
|
if feature in features then
|
|
begin
|
|
str(feature,s);
|
|
s:=copy(s,3,255);
|
|
writeln([s]);
|
|
end;
|
|
|
|
end;
|
|
|
|
ibmoduleoptions:
|
|
if not silent then
|
|
readmoduleoptions(' ');
|
|
|
|
ibsourcefiles :
|
|
begin
|
|
sourcenumber:=1;
|
|
if not silent then
|
|
while not EndOfEntry do
|
|
begin
|
|
with TPpuSrcFile.Create(CurUnit.SourceFiles) do begin
|
|
Name:=getstring;
|
|
i:=getlongint;
|
|
try
|
|
if i >= 0 then
|
|
FileTime:=FileDateToDateTime(i);
|
|
Writeln(['Source file ',sourcenumber,' : ',Name,' ',filetimestring(i)]);
|
|
except
|
|
end;
|
|
end;
|
|
|
|
inc(sourcenumber);
|
|
end;
|
|
end;
|
|
{$IFDEF MACRO_DIFF_HINT}
|
|
ibusedmacros :
|
|
begin
|
|
if not silent then
|
|
while not EndOfEntry do
|
|
begin
|
|
Write('Conditional ',getstring);
|
|
if getboolean then
|
|
write(' defined at startup')
|
|
else
|
|
write(' not defined at startup');
|
|
if getboolean then
|
|
writeln(' was used')
|
|
else
|
|
writeln;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
ibloadunit :
|
|
if not silent then
|
|
ReadLoadUnit;
|
|
|
|
iblinkunitofiles :
|
|
if not silent then
|
|
ReadLinkContainer('Link unit object file: ');
|
|
|
|
iblinkunitstaticlibs :
|
|
if not silent then
|
|
ReadLinkContainer('Link unit static lib: ');
|
|
|
|
iblinkunitsharedlibs :
|
|
if not silent then
|
|
ReadLinkContainer('Link unit shared lib: ');
|
|
|
|
iblinkotherofiles :
|
|
if not silent then
|
|
ReadLinkContainer('Link other object file: ');
|
|
|
|
iblinkotherstaticlibs :
|
|
if not silent then
|
|
ReadLinkContainer('Link other static lib: ');
|
|
|
|
iblinkothersharedlibs :
|
|
if not silent then
|
|
ReadLinkContainer('Link other shared lib: ');
|
|
|
|
iblinkotherframeworks:
|
|
if not silent then
|
|
ReadLinkContainer('Link framework: ');
|
|
|
|
ibjvmnamespace:
|
|
Writeln('JVM name space: '+getString);
|
|
ibmainname:
|
|
if not silent then
|
|
Writeln(['Specified main program symbol name: ',getstring]);
|
|
|
|
ibImportSymbols :
|
|
if not silent then
|
|
ReadImportSymbols;
|
|
|
|
ibderefdata :
|
|
ReadDerefData;
|
|
|
|
ibderefmap :
|
|
ReadDerefMap;
|
|
|
|
ibwpofile :
|
|
if not silent then
|
|
ReadWpoFileInfo;
|
|
|
|
ibresources :
|
|
if not silent then
|
|
ReadContainer('Resource file: ');
|
|
|
|
iborderedsymbols:
|
|
if not silent then
|
|
ReadContainer('Ordered symbol: ');
|
|
|
|
iberror :
|
|
begin
|
|
WriteError('Error in PPU');
|
|
exit;
|
|
end;
|
|
|
|
ibendinterface :
|
|
break;
|
|
|
|
else
|
|
begin
|
|
WriteError('!! Skipping unsupported PPU Entry in General Part: '+IntToStr(b));
|
|
end;
|
|
end;
|
|
until false;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{****************************************************************************
|
|
Read Implementation Part
|
|
****************************************************************************}
|
|
|
|
procedure readimplementation;
|
|
var
|
|
b : byte;
|
|
begin
|
|
with ppufile do
|
|
begin
|
|
repeat
|
|
b:=readentry;
|
|
case b of
|
|
ibasmsymbols :
|
|
ReadAsmSymbols;
|
|
|
|
ibloadunit :
|
|
ReadLoadUnit;
|
|
|
|
ibunitimportsyms :
|
|
ReadUnitImportSyms;
|
|
|
|
iberror :
|
|
begin
|
|
WriteError('Error in PPU');
|
|
exit;
|
|
end;
|
|
ibendimplementation :
|
|
break;
|
|
else
|
|
begin
|
|
WriteError('!! Skipping unsupported PPU Entry in Implementation: '+IntToStr(b));
|
|
end;
|
|
end;
|
|
until false;
|
|
end;
|
|
end;
|
|
|
|
|
|
function parseextraheader(module: TPpuModuleDef; ppufile: tppufile): boolean;
|
|
var
|
|
b: byte;
|
|
begin
|
|
result:=false;
|
|
b:=ppufile.readentry;
|
|
if b<>ibextraheader then
|
|
exit;
|
|
CurUnit.LongVersion:=cardinal(ppufile.getlongint);
|
|
Writeln(['LongVersion: ',CurUnit.LongVersion]);
|
|
ppufile.getset(tppuset4(CurUnit.ModuleFlags));
|
|
result:=ppufile.EndOfEntry and (CurUnit.LongVersion=CurrentPPULongVersion);
|
|
if mf_symansistr in CurUnit.ModuleFlags then
|
|
SymAnsiStr:=true;
|
|
end;
|
|
|
|
procedure dofile (filename : string);
|
|
begin
|
|
{ reset }
|
|
space:='';
|
|
{ fix filename }
|
|
if pos('.',filename)=0 then
|
|
filename:=filename+'.ppu';
|
|
ppufile:=tppudumpfile.create(filename);
|
|
if not ppufile.openfile then
|
|
begin
|
|
WriteError('IO-Error when opening : '+filename+', Skipping');
|
|
exit;
|
|
end;
|
|
{ PPU File is open, check for PPU Id }
|
|
if not ppufile.CheckPPUID then
|
|
begin
|
|
WriteError(Filename+' : Not a valid PPU file, Skipping');
|
|
exit;
|
|
end;
|
|
{ Check PPU Version }
|
|
ppuversion:=ppufile.getversion;
|
|
|
|
Writeln(['Analyzing ',filename,' (v',PPUVersion,')']);
|
|
|
|
if not SkipVersionCheck and (PPUVersion <> CurrentPPUVersion) then
|
|
begin
|
|
WriteError(Format('Unsupported PPU version %d. Expecting PPU version %d.', [PPUVersion, CurrentPPUVersion]));
|
|
exit;
|
|
end;
|
|
|
|
CurUnit:=TPpuModuleDef.Create(UnitList);
|
|
CurUnit.Version:=ppuversion;
|
|
|
|
if not parseextraheader(CurUnit, ppufile) then
|
|
begin
|
|
WriteError(Format('Unsupported PPU sub-version %d. Expecting PPU sub-version %d.', [CurUnit.LongVersion, CurrentPPULongVersion]));
|
|
end;
|
|
|
|
{ Write PPU Header Information }
|
|
if (verbose and v_header)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Header');
|
|
Writeln('-------');
|
|
with ppufile.header do
|
|
begin
|
|
Writeln(['Compiler version : ',ppufile.header.common.compiler shr 14,'.',
|
|
(ppufile.header.common.compiler shr 7) and $7f,'.',
|
|
ppufile.header.common.compiler and $7f]);
|
|
WriteLn(['Target processor : ',Cpu2Str(common.cpu)]);
|
|
WriteLn(['Target operating system : ',Target2Str(common.target)]);
|
|
Writeln(['Unit flags : ',PPUFlags2Str(common.flags)]);
|
|
Writeln(['FileSize (w/o header) : ',common.size]);
|
|
Writeln(['Checksum : ',hexstr(checksum,8)]);
|
|
Writeln(['Interface Checksum : ',hexstr(interface_checksum,8)]);
|
|
Writeln(['Indirect Checksum : ',hexstr(indirect_checksum,8)]);
|
|
Writeln(['Definitions stored : ',tostr(deflistsize)]);
|
|
Writeln(['Symbols stored : ',tostr(symlistsize)]);
|
|
end;
|
|
end;
|
|
|
|
with ppufile.header do
|
|
begin
|
|
CurUnit.Crc:=checksum;
|
|
CurUnit.IntfCrc:=interface_checksum;
|
|
CurUnit.TargetCPU:=Cpu2Str(common.cpu);
|
|
CurUnit.TargetOS:=Target2Str(common.target);
|
|
end;
|
|
|
|
{read the general stuff}
|
|
if (verbose and v_interface)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Interface section');
|
|
Writeln('------------------');
|
|
readinterface(false);
|
|
end
|
|
{ We need derefdata from Interface }
|
|
else if verbose and (v_defs or v_syms or v_implementation)<>0 then
|
|
readinterface(true)
|
|
else
|
|
ppufile.skipuntilentry(ibendinterface);
|
|
Writeln;
|
|
Writeln('Interface symtable');
|
|
Writeln('----------------------');
|
|
readsymtableoptions('interface');
|
|
{read the definitions}
|
|
if (verbose and v_defs)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Interface definitions');
|
|
Writeln('----------------------');
|
|
readdefinitions('interface', CurUnit);
|
|
end
|
|
else
|
|
ppufile.skipuntilentry(ibenddefs);
|
|
{read the symbols}
|
|
if (verbose and v_syms)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Interface Symbols');
|
|
Writeln('------------------');
|
|
readsymbols('interface',CurUnit);
|
|
end
|
|
else
|
|
ppufile.skipuntilentry(ibendsyms);
|
|
|
|
{read the macro symbols}
|
|
if (verbose and v_syms)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Interface Macro Symbols');
|
|
Writeln('-----------------------');
|
|
end;
|
|
if ppufile.readentry<>ibexportedmacros then
|
|
begin
|
|
WriteError('!! Error in PPU');
|
|
exit;
|
|
end;
|
|
if ppufile.getboolean then
|
|
begin
|
|
readsymtableoptions('interface macro');
|
|
{skip the definition section for macros (since they are never used) }
|
|
ppufile.skipuntilentry(ibenddefs);
|
|
{read the macro symbols}
|
|
if (verbose and v_syms)<>0 then
|
|
readsymbols('interface macro')
|
|
else
|
|
ppufile.skipuntilentry(ibendsyms);
|
|
end
|
|
else
|
|
Writeln('(no exported macros)');
|
|
|
|
{read the implementation stuff}
|
|
if (verbose and v_implementation)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Implementation section');
|
|
Writeln('-----------------------');
|
|
readimplementation;
|
|
end
|
|
else
|
|
ppufile.skipuntilentry(ibendimplementation);
|
|
{read the static symtable}
|
|
Writeln;
|
|
Writeln('Implementation symtable');
|
|
Writeln('----------------------');
|
|
readsymtableoptions('implementation');
|
|
if (mf_local_symtable in CurUnit.ModuleFlags) then
|
|
begin
|
|
if (verbose and v_defs)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Static definitions');
|
|
Writeln('----------------------');
|
|
readdefinitions('implementation', nil);
|
|
end
|
|
else
|
|
ppufile.skipuntilentry(ibenddefs);
|
|
{read the symbols}
|
|
if (verbose and v_syms)<>0 then
|
|
begin
|
|
Writeln;
|
|
Writeln('Static Symbols');
|
|
Writeln('------------------');
|
|
readsymbols('implementation');
|
|
end
|
|
else
|
|
ppufile.skipuntilentry(ibendsyms);
|
|
end;
|
|
ReadCreatedObjTypes;
|
|
FreeDerefdata;
|
|
{shutdown ppufile}
|
|
ppufile.closefile;
|
|
ppufile.free;
|
|
Writeln;
|
|
end;
|
|
|
|
procedure WriteLogo;
|
|
begin
|
|
writeln(Title+' Version '+version_string);
|
|
writeln(Copyright);
|
|
writeln;
|
|
end;
|
|
|
|
procedure help;
|
|
begin
|
|
WriteLogo;
|
|
writeln('usage: ppudump [options] <filename1> <filename2>...');
|
|
writeln;
|
|
writeln('[options] can be:');
|
|
writeln(' -F<format> Set output format to <format>');
|
|
writeln(' t - text format (default)');
|
|
writeln(' j - JSON format');
|
|
writeln(' x - XML format');
|
|
writeln(' -M Exit with ExitCode=2 if more information is available');
|
|
writeln(' -S Skip PPU version check. May lead to reading errors');
|
|
writeln(' -V<verbose> Set verbosity to <verbose>');
|
|
writeln(' H - Show header info');
|
|
writeln(' I - Show interface');
|
|
writeln(' M - Show implementation');
|
|
writeln(' S - Show interface symbols');
|
|
writeln(' D - Show interface definitions');
|
|
writeln(' A - Show all');
|
|
writeln(' -h, -? This helpscreen');
|
|
halt;
|
|
end;
|
|
|
|
var
|
|
startpara,
|
|
nrfile,i : longint;
|
|
para : string;
|
|
const
|
|
error_on_more : boolean = false;
|
|
begin
|
|
if paramcount<1 then
|
|
help;
|
|
{ turn verbose on by default }
|
|
verbose:=v_all;
|
|
{ read options }
|
|
startpara:=1;
|
|
while copy(paramstr(startpara),1,1)='-' do
|
|
begin
|
|
para:=paramstr(startpara);
|
|
case upcase(para[2]) of
|
|
'F' : begin
|
|
FreeAndNil(pout);
|
|
if Length(para) > 2 then
|
|
case upcase(para[3]) of
|
|
'T':
|
|
nostdout:=False;
|
|
'J':
|
|
begin
|
|
nostdout:=True;
|
|
pout:=TPpuJsonOutput.Create(StdOutputHandle);
|
|
end;
|
|
'X':
|
|
begin
|
|
nostdout:=True;
|
|
pout:=TPpuXmlOutput.Create(StdOutputHandle);
|
|
end;
|
|
else
|
|
begin
|
|
WriteError('Invalid output format: ' + para[3]);
|
|
Halt(1);
|
|
end;
|
|
end;
|
|
end;
|
|
'M' : error_on_more:=true;
|
|
'S' : SkipVersionCheck:=True;
|
|
'V' : begin
|
|
verbose:=0;
|
|
for i:=3 to length(para) do
|
|
case upcase(para[i]) of
|
|
'H' : verbose:=verbose or v_header;
|
|
'I' : verbose:=verbose or v_interface;
|
|
'M' : verbose:=verbose or v_implementation;
|
|
'D' : verbose:=verbose or v_defs;
|
|
'S' : verbose:=verbose or v_syms;
|
|
'A' : verbose:=verbose or v_all;
|
|
end;
|
|
end;
|
|
'H' : help;
|
|
'?' : help;
|
|
else
|
|
begin
|
|
WriteError('Invalid option: ' + para);
|
|
Halt(1);
|
|
end;
|
|
end;
|
|
inc(startpara);
|
|
end;
|
|
|
|
if not nostdout then
|
|
WriteLogo;
|
|
|
|
UnitList:=TPpuContainerDef.Create(nil);
|
|
try
|
|
UnitList.ItemsName:='';
|
|
{ process files }
|
|
for nrfile:=startpara to paramcount do
|
|
dofile (paramstr(nrfile));
|
|
if not has_errors and (pout <> nil) then
|
|
begin
|
|
pout.Init;
|
|
UnitList.Write(pout);
|
|
pout.Done;
|
|
end;
|
|
finally
|
|
UnitList.Free;
|
|
pout.Free;
|
|
end;
|
|
if has_errors then
|
|
Halt(1);
|
|
if error_on_more and
|
|
(has_more_infos or has_warnings) then
|
|
Halt(2);
|
|
end.
|
|
|