{ Copyright (c) 1998-2013 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-2013 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 } 'wasm', { 18 } 'sparc64' ); 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 {'wasm'}, { 18 } false {'sparc64'} ); { 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 } 'MacOS-m68k', { 10 } 'Linux-m68k', { 11 } 'PalmOS-m68k', { 12 } 'Linux-alpha (obsolete)', { 13 } 'Linux-ppc', { 14 } 'MacOS-ppc', { 15 } 'Solaris-i386', { 16 } 'BeOS-i386', { 17 } 'NetBSD-i386', { 18 } 'NetBSD-m68k', { 19 } 'Netware-i386-clib', { 20 } 'Qnx-i386', { 21 } 'WDOSX-i386', { 22 } 'Solaris-sparc', { 23 } 'Linux-sparc', { 24 } 'OpenBSD-i386', { 25 } 'OpenBSD-m68k (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 } 'Darwin-ARM', { 65 } 'Solaris-x86-64', { 66 } 'Linux-MIPS', { 67 } 'Linux-MIPSel', { 68 } 'NativeNT-i386', { 69 } 'iPhoneSim-i386', { 70 } 'Wii-powerpc', { 71 } 'OpenBSD-x86-64', { 72 } 'NetBSD-x86-64', { 73 } 'AIX-powerpc', { 74 } 'AIX-powerpc64', { 75 } 'Java-JVM', { 76 } 'Android-JVM', { 77 } 'Android-arm', { 78 } 'Android-i386', { 79 } 'MSDOS-i8086', { 80 } 'Android-MIPSel', { 81 } 'Embedded-mipseb', { 82 } 'Embedded-mipsel', { 83 } 'AROS-i386', { 84 } 'AROS-x86-64', { 85 } 'DragonFly-x86-64', { 86 } 'Darwin-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' ); 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_wasm = ( cpu_variant_wasm_none); tcpu_sparc64 = ( cpu_variant_sparc64_none, cpu_variant_SPARC64_V9 ); 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_wasm: { 17 } (cpu_wasm : tcpu_wasm;); cpu_sparc64: { 18 } (cpu_sparc64 : tcpu_sparc64;); end; TPpuModuleDef = class(TPpuUnitDef) // ModuleFlags: tmoduleflags; { not yet merged } end; type tppudumpfile = class(tppufile) 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: TPpuUnitDef; SkipVersionCheck: 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); {$ifdef FPC_LITTLE_ENDIAN} 2: (cards: Array[0..1] of cardinal; w: word); {$else not FPC_LITTLE_ENDIAN} 2: (w:word; cards: Array[0..1] of cardinal); {$endif not FPC_LITTLE_ENDIAN} 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; mantval : qword; begin if ppufile.change_endian then begin for i:=0 to 9 do new.bytes[i]:=e.bytes[9-i]; e:=new; end; 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 } sign := (e.w and $8000) <> 0; expMaximal := (e.w and $7fff) = 32767; exp:=(e.w and $7fff) - 16383 - 63; fraczero := (e.cards[0] = 0) and ((e.cards[1] and $7fffffff) = 0); {$ifdef FPC_LITTLE_ENDIAN} mantval := qword(e.cards[0]) or (qword(e.cards[1]) shl 32); {$else not FPC_LITTLE_ENDIAN} mantval := (qword(e.cards[0]) shl 32) or qword(e.cards[1]); {$endif not FPC_LITTLE_ENDIAN} 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; 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:=''; 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','' ); 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=32; flagopt : array[1..flagopts] of tflagopt=( (mask: $1 ;str:'init'), (mask: $2 ;str:'final'), (mask: $4 ;str:'big_endian'), (mask: $8 ;str:'dbx'), // (mask: $10 ;str:'browser'), (mask: $20 ;str:'in_library'), (mask: $40 ;str:'smart_linked'), (mask: $80 ;str:'static_linked'), (mask: $100 ;str:'shared_linked'), (mask: $200 ;str:'uses_checkpointer'), (mask: $400 ;str:'no_link'), (mask: $800 ;str:'has_resources'), (mask: $1000 ;str:'little_endian'), (mask: $2000 ;str:'release'), (mask: $4000 ;str:'local_threadvars'), (mask: $8000 ;str:'fpu_emulation_on'), (mask: $210000 ;str:'has_debug_info'), (mask: $10000 ;str:'stabs_debug_info'), (mask: $200000 ;str:'dwarf_debug_info'), (mask: $20000 ;str:'local_symtable'), (mask: $40000 ;str:'uses_variants'), (mask: $80000 ;str:'has_resourcefiles'), (mask: $100000 ;str:'has_exports'), (mask: $400000 ;str:'has_wideinits'), (mask: $800000 ;str:'has_classinits'), (mask: $1000000 ;str:'has_resstrinits'), (mask: $2000000 ;str:'i8086_far_code'), (mask: $4000000 ;str:'i8086_far_data'), (mask: $8000000 ;str:'i8086_huge_data'), (mask: $10000000;str:'i8086_cs_equals_ds'), (mask: $20000000;str:'package_deny'), (mask: $40000000;str:'package_weak'), (mask: dword($80000000);str:'i8086_ss_equals_ds') ); var i : longint; ntflags : dword; first : boolean; s : string; begin s:=''; ntflags:=flags; 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; 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; 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 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.getsmallset(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; if ppuversion>130 then extsymmangledname:=ppufile.getstring else extsymmangledname:=extsymname; 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); 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 ); 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'; else begin bindstr:=''; 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'; else begin typestr:=''; 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:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3]; inc(i,4); write(['SymId ',idx]); if Ref <> nil then Ref.Id:=idx; end; deref_defid : begin idx:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3]; inc(i,4); write(['DefId ',idx]); if Ref <> nil then Ref.Id:=idx; end; deref_unit : begin idx:=pdata[i] shl 8 or pdata[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_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[81]; 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 ') ); var procinfooptions : tprocinfoflags; i : longint; first : boolean; begin ppufile.getsmallset(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') ); var symoptions : tsymoptions; i : longint; first : boolean; begin ppufile.getsmallset(symoptions); if symoptions<>[] then begin if Def <> nil then if sp_internal in symoptions then Def.Visibility:=dvHidden; 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 readcommonsym(const s:string; Def: TPpuDef = nil); var i: integer; n: string; begin n:=ppufile.getstring; 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); 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.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); { 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[30] = { 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} ); moduleswitchname : array[tmoduleswitch] of string[40] = ('Module None', {cs_modulenone,} { parser } 'Floating Point Emulation',{ cs_fp_emulation} 'Extended syntax', {cs_extsyntax} 'Open string', {cs_openstring} { 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 } 'Hude code', {cs_huge_code} 'Win16 smart callbacks', {cs_win16_smartcallbacks} { Record usage of checkpointer experimental feature } 'CheckPointer used' {cs_checkpointer_called} ); globalswitchname : array[tglobalswitch] of string[50] = ('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 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} ); 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} {not yet merged} // 'Check all case coverage', {cs_check_all_case_coverage} {not yet merged} { 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} { 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} ); { 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 } {not yet merged} // 'm_array2dynarray', { regular arrays can be implicitly converted to dynamic arrays } {not yet merged} // 'm_prefixed_attributes' { enable attributes that are defined before the type they belong to } {not yet merged} ); { optimizer } optimizerswitchname : array[toptimizerswitch] of string[50] = ('cs_opt_none', '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_emtpy_proc', 'cs_opt_constant_propagate', 'cs_opt_dead_store_eliminate', 'cs_opt_forcenostackframe', 'cs_opt_use_load_modify_store' ); 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)); {not yet merged} { 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)); {not yet merged} { 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)); {not yet merged} 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_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)0 then begin dump_new_settings; writeln; end else begin writeln('Unchanged'); end; prev_settings:=new_settings; end; ST_LOADMESSAGES: begin inc(tbi); mesgnb:=tokenbuf[tbi]; writeln([space,mesgnb,' messages: ']); inc(tbi); for nb:=1 to mesgnb do begin msgvalue:=gettokenbufsizeint; //inc(tbi,sizeof(sizeint)); state:=tmsgstate(gettokenbufsizeint); 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) 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.getsmallset(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.getsmallset(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_genconstraint in defoptions then begin ppufile.getsmallset(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; 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[31]; 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') ); 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_objc_related_result_type; str: 'Objective-C related result type') ); 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.getnormalset(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') ); var i : longint; 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)]); writeln([space,' Addr Taken : ',(ppufile.getbyte<>0)]); writeln([space,'Escaped Scope : ',(ppufile.getbyte<>0)]); write ([space,' Var Type : ']); if VarDef <> nil then readderef('',VarDef.VarType) else readderef(''); ppufile.getsmallset(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') ); var i : longint; first : boolean; begin ppufile.getsmallset(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 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') ); var i: timplprocoption; first: boolean; begin ppufile.getsmallset(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' ); var symoptions: tarraydefoptions; i: tarraydefoption; first: boolean; begin ppufile.getsmallset(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.getsmallset(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.getsmallset(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; 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; 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 if tsystemcpu(ppufile.header.common.cpu)=cpu_jvm then writeln([space,'AMangledname : ',getansistring]) else writeln([space,'SMangledname : ',getstring]); 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 (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 ); } { 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; 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; 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 if tsystemcpu(ppufile.header.common.cpu)=cpu_jvm then writeln([space,' Mangled name : ',getansistring]) else writeln([space,' Mangled name : ',getstring]); 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 j0 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'); { not yet merged } 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); 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); 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 (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.getsmallset(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 getsmallset(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; if i >= 0 then FileTime:=FileDateToDateTime(i); Writeln(['Source file ',sourcenumber,' : ',Name,' ',filetimestring(i)]); 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: '); 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; 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 PPUVersion<16 then begin WriteError(Filename+' : Old PPU Formats ( CurrentPPUVersion) then begin WriteError(Format('Unsupported PPU version %d. Expecting PPU version %d.', [PPUVersion, CurrentPPUVersion])); exit; end; CurUnit:=TPpuUnitDef.Create(UnitList); CurUnit.Version:=ppuversion; { 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 (ppufile.header.common.flags and uf_local_symtable)<>0 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] ...'); writeln; writeln('[options] can be:'); writeln(' -F Set output format to '); 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 Set verbosity to '); 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.