|
|
@@ -0,0 +1,1580 @@
|
|
|
+{
|
|
|
+ $Id$
|
|
|
+ Copyright (c) 1998-2000 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.
|
|
|
+
|
|
|
+ ****************************************************************************}
|
|
|
+{$ifdef TP}
|
|
|
+ {$N+,E+}
|
|
|
+{$endif}
|
|
|
+program pppdump;
|
|
|
+uses
|
|
|
+{$ifdef go32v2}
|
|
|
+ dpmiexcp,
|
|
|
+{$endif go32v2}
|
|
|
+ ppu;
|
|
|
+
|
|
|
+const
|
|
|
+ Version = 'Version 1.10';
|
|
|
+ Title = 'PPU-Analyser';
|
|
|
+ Copyright = 'Copyright (c) 1998-2000 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;
|
|
|
+
|
|
|
+var
|
|
|
+ ppufile : pppufile;
|
|
|
+ space : string;
|
|
|
+ read_member : boolean;
|
|
|
+ verbose : longint;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Helper Routines
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+const has_errors : boolean = false;
|
|
|
+Procedure Error(const S : string);
|
|
|
+Begin
|
|
|
+ Writeln(S);
|
|
|
+ has_errors:=true;
|
|
|
+End;
|
|
|
+
|
|
|
+Function Target2Str(w:longint):string;
|
|
|
+type
|
|
|
+ ttarget = (target_none
|
|
|
+ ,target_i386_GO32V1,target_i386_GO32V2,target_i386_linux,
|
|
|
+ target_i386_OS2,target_i386_Win32
|
|
|
+ ,target_m68k_Amiga,target_m68k_Atari,target_m68k_Mac,
|
|
|
+ target_m68k_linux,target_m68k_PalmOS
|
|
|
+ );
|
|
|
+const
|
|
|
+ Targets : array[ttarget] of string[10]=('none',
|
|
|
+ 'GO32V1','GO32V2','Linux-i386','OS/2','Win32',
|
|
|
+ 'Amiga','Mac68k','Atari','Linux-m68k','PalmOs');
|
|
|
+begin
|
|
|
+ if w<=ord(high(ttarget)) then
|
|
|
+ Target2Str:=Targets[ttarget(w)]
|
|
|
+ else
|
|
|
+ Target2Str:='<Unknown>';
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+Function Cpu2Str(w:longint):string;
|
|
|
+type
|
|
|
+ ttargetcpu=(no_cpu
|
|
|
+ ,i386,m68k,alpha
|
|
|
+ );
|
|
|
+const
|
|
|
+ CpuTxt : array[ttargetcpu] of string[5]=
|
|
|
+ ('none','i386','m68k','alpha');
|
|
|
+begin
|
|
|
+ if w<=ord(high(ttargetcpu)) then
|
|
|
+ Cpu2Str:=CpuTxt[ttargetcpu(w)]
|
|
|
+ else
|
|
|
+ Cpu2Str:='<Unknown>';
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function PPUFlags2Str(flags:longint):string;
|
|
|
+type
|
|
|
+ tflagopt=record
|
|
|
+ mask : longint;
|
|
|
+ str : string[30];
|
|
|
+ end;
|
|
|
+const
|
|
|
+ flagopts=11;
|
|
|
+ flagopt : array[1..flagopts] of tflagopt=(
|
|
|
+ (mask: $1 ;str:'init'),
|
|
|
+ (mask: $2 ;str:'final'),
|
|
|
+ (mask: $4 ;str:'big_endian'),
|
|
|
+ (mask: $8 ;str:'dbx'),
|
|
|
+ (mask: $10 ;str:'browser'),
|
|
|
+ (mask: $20 ;str:'in_library'),
|
|
|
+ (mask: $40 ;str:'smart_linked'),
|
|
|
+ (mask: $80 ;str:'static_linked'),
|
|
|
+ (mask: $100 ;str:'shared_linked'),
|
|
|
+ (mask: $200 ;str:'local_browser'),
|
|
|
+ (mask: $400 ;str:'no_link')
|
|
|
+ );
|
|
|
+var
|
|
|
+ i : longint;
|
|
|
+ first : boolean;
|
|
|
+ s : string;
|
|
|
+begin
|
|
|
+ s:='';
|
|
|
+ if flags<>0 then
|
|
|
+ begin
|
|
|
+ first:=true;
|
|
|
+ for i:=1to flagopts do
|
|
|
+ if (flags and flagopt[i].mask)<>0 then
|
|
|
+ begin
|
|
|
+ if first then
|
|
|
+ first:=false
|
|
|
+ else
|
|
|
+ s:=s+', ';
|
|
|
+ s:=s+flagopt[i].str;
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ s:='none';
|
|
|
+ PPUFlags2Str:=s;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+const
|
|
|
+ HexTbl : array[0..15] of char='0123456789ABCDEF';
|
|
|
+function HexB(b:byte):string;
|
|
|
+begin
|
|
|
+ HexB[0]:=#2;
|
|
|
+ HexB[1]:=HexTbl[b shr 4];
|
|
|
+ HexB[2]:=HexTbl[b and $f];
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read Routines
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+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;
|
|
|
+ const
|
|
|
+ { link options }
|
|
|
+ link_none = $0;
|
|
|
+ link_allways = $1;
|
|
|
+ link_static = $2;
|
|
|
+ link_smart = $4;
|
|
|
+ link_shared = $8;
|
|
|
+ var
|
|
|
+ s : string;
|
|
|
+ begin
|
|
|
+ s:='';
|
|
|
+ if (m and link_allways)<>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 serie of strings and write to the screen starting every line
|
|
|
+ with prefix
|
|
|
+}
|
|
|
+begin
|
|
|
+ while not ppufile^.endofentry do
|
|
|
+ WriteLn(prefix,ppufile^.getstring);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+Procedure ReadRef;
|
|
|
+begin
|
|
|
+ if (verbose and v_browser)=0 then
|
|
|
+ exit;
|
|
|
+ while (not ppufile^.endofentry) and (not ppufile^.error) do
|
|
|
+ Writeln(space,' - Refered : ',ppufile^.getword,', (',ppufile^.getlongint,',',ppufile^.getword,')');
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+Procedure ReadPosInfo;
|
|
|
+begin
|
|
|
+ Writeln(ppufile^.getword,' (',ppufile^.getlongint,',',ppufile^.getword,')');
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function readderef(const s:string;skipnil:boolean):boolean;
|
|
|
+type
|
|
|
+ tdereftype = (derefnil,derefaktrecordindex,derefaktstaticindex,
|
|
|
+ derefunit,derefrecord,derefindex,
|
|
|
+ dereflocal,derefpara,derefaktlocalindex);
|
|
|
+var
|
|
|
+ b : tdereftype;
|
|
|
+begin
|
|
|
+ readderef:=true;
|
|
|
+ repeat
|
|
|
+ b:=tdereftype(ppufile^.getbyte);
|
|
|
+ case b of
|
|
|
+ derefnil :
|
|
|
+ begin
|
|
|
+ if not skipnil then
|
|
|
+ writeln('nil');
|
|
|
+ readderef:=false;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ derefaktrecordindex :
|
|
|
+ begin
|
|
|
+ writeln('AktRecord ',s,' ',ppufile^.getword);
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ derefaktstaticindex :
|
|
|
+ begin
|
|
|
+ writeln('AktStatic ',s,' ',ppufile^.getword);
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ derefaktlocalindex :
|
|
|
+ begin
|
|
|
+ writeln('AktLocal ',s,' ',ppufile^.getword);
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ derefunit :
|
|
|
+ begin
|
|
|
+ writeln('Unit ',ppufile^.getword);
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ derefrecord :
|
|
|
+ begin
|
|
|
+ write('RecordDef ',ppufile^.getword,', ');
|
|
|
+ end;
|
|
|
+ derefpara :
|
|
|
+ begin
|
|
|
+ write('Parameter of procdef ',ppufile^.getword,', ');
|
|
|
+ end;
|
|
|
+ dereflocal :
|
|
|
+ begin
|
|
|
+ write('Local of procdef ',ppufile^.getword,', ');
|
|
|
+ end;
|
|
|
+ derefindex :
|
|
|
+ begin
|
|
|
+ write(s,' ',ppufile^.getword,', ');
|
|
|
+ end;
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ writeln('!! unsupported dereftyp: ',ord(b));
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ until false;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function readdefref:boolean;
|
|
|
+begin
|
|
|
+ readdefref:=readderef('Definition',false);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function readsymref:boolean;
|
|
|
+begin
|
|
|
+ readsymref:=readderef('Symbol',false);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure readtype;
|
|
|
+var
|
|
|
+ b1,b2 : boolean;
|
|
|
+begin
|
|
|
+ b1:=readderef('Definition',true);
|
|
|
+ b2:=readderef('Symbol',true);
|
|
|
+ if not(b1 or b2) then
|
|
|
+ Writeln('nil')
|
|
|
+ else
|
|
|
+ if (b1 and b2) then
|
|
|
+ Writeln('!! Type has both definition and symbol stored');
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure readsymlist(const s:string);
|
|
|
+begin
|
|
|
+ readdefref;
|
|
|
+ repeat
|
|
|
+ write(s);
|
|
|
+ if not readsymref then
|
|
|
+ break;
|
|
|
+ until false;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure read_abstract_proc_def;
|
|
|
+type
|
|
|
+ tproccalloption=(pocall_none,
|
|
|
+ pocall_clearstack, { Use IBM flat calling convention. (Used by GCC.) }
|
|
|
+ pocall_leftright, { Push parameters from left to right }
|
|
|
+ pocall_cdecl, { procedure uses C styled calling }
|
|
|
+ pocall_register, { procedure uses register (fastcall) calling }
|
|
|
+ pocall_stdcall, { procedure uses stdcall call }
|
|
|
+ pocall_safecall, { safe call calling conventions }
|
|
|
+ pocall_palmossyscall, { procedure is a PalmOS system call }
|
|
|
+ pocall_system,
|
|
|
+ pocall_inline, { Procedure is an assembler macro }
|
|
|
+ pocall_internproc, { Procedure has compiler magic}
|
|
|
+ pocall_internconst { procedure has constant evaluator intern }
|
|
|
+ );
|
|
|
+ tproccalloptions=set of tproccalloption;
|
|
|
+ tproctypeoption=(potype_none,
|
|
|
+ potype_proginit, { Program initialization }
|
|
|
+ potype_unitinit, { unit initialization }
|
|
|
+ potype_unitfinalize, { unit finalization }
|
|
|
+ potype_constructor, { Procedure is a constructor }
|
|
|
+ potype_destructor, { Procedure is a destructor }
|
|
|
+ potype_operator { Procedure defines an operator }
|
|
|
+ );
|
|
|
+ tproctypeoptions=set of tproctypeoption;
|
|
|
+ tprocoption=(po_none,
|
|
|
+ po_classmethod, { class method }
|
|
|
+ po_virtualmethod, { Procedure is a virtual method }
|
|
|
+ po_abstractmethod, { Procedure is an abstract method }
|
|
|
+ po_staticmethod, { static method }
|
|
|
+ po_overridingmethod, { method with override directive }
|
|
|
+ po_methodpointer, { method pointer, only in procvardef, also used for 'with object do' }
|
|
|
+ po_containsself, { self is passed explicit to the compiler }
|
|
|
+ po_interrupt, { Procedure is an interrupt handler }
|
|
|
+ po_iocheck, { IO checking should be done after a call to the procedure }
|
|
|
+ po_assembler, { Procedure is written in assembler }
|
|
|
+ po_msgstr, { method for string message handling }
|
|
|
+ po_msgint, { method for int message handling }
|
|
|
+ po_exports, { Procedure has export directive (needed for OS/2) }
|
|
|
+ po_external, { Procedure is external (in other object or lib)}
|
|
|
+ po_savestdregs, { save std regs cdecl and stdcall need that ! }
|
|
|
+ po_saveregisters { save all registers }
|
|
|
+ );
|
|
|
+ tprocoptions=set of tprocoption;
|
|
|
+type
|
|
|
+ tproccallopt=record
|
|
|
+ mask : tproccalloption;
|
|
|
+ str : string[30];
|
|
|
+ end;
|
|
|
+ tproctypeopt=record
|
|
|
+ mask : tproctypeoption;
|
|
|
+ str : string[30];
|
|
|
+ end;
|
|
|
+ tprocopt=record
|
|
|
+ mask : tprocoption;
|
|
|
+ str : string[30];
|
|
|
+ end;
|
|
|
+const
|
|
|
+ proccallopts=12;
|
|
|
+ proccallopt : array[1..proccallopts] of tproccallopt=(
|
|
|
+ (mask:pocall_none; str:''),
|
|
|
+ (mask:pocall_clearstack; str:'ClearStack'),
|
|
|
+ (mask:pocall_leftright; str:'LeftRight'),
|
|
|
+ (mask:pocall_cdecl; str:'Cdecl'),
|
|
|
+ (mask:pocall_register; str:'Register'),
|
|
|
+ (mask:pocall_stdcall; str:'StdCall'),
|
|
|
+ (mask:pocall_safecall; str:'SafeCall'),
|
|
|
+ (mask:pocall_palmossyscall;str:'PalmOSSysCall'),
|
|
|
+ (mask:pocall_system; str:'System'),
|
|
|
+ (mask:pocall_inline; str:'Inline'),
|
|
|
+ (mask:pocall_internproc; str:'InternProc'),
|
|
|
+ (mask:pocall_internconst; str:'InternConst')
|
|
|
+ );
|
|
|
+ proctypeopts=6;
|
|
|
+ proctypeopt : array[1..proctypeopts] 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')
|
|
|
+ );
|
|
|
+ procopts=16;
|
|
|
+ procopt : array[1..procopts] of tprocopt=(
|
|
|
+ (mask:po_classmethod; str:'ClassMethod'),
|
|
|
+ (mask:po_virtualmethod; str:'VirtualMethod'),
|
|
|
+ (mask:po_abstractmethod; str:'AbstractMethod'),
|
|
|
+ (mask:po_staticmethod; str:'StaticMethod'),
|
|
|
+ (mask:po_overridingmethod;str:'OverridingMethod'),
|
|
|
+ (mask:po_methodpointer; str:'MethodPointer'),
|
|
|
+ (mask:po_containsself; str:'ContainsSelf'),
|
|
|
+ (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_savestdregs; str:'SaveStdRegs'),
|
|
|
+ (mask:po_saveregisters; str:'SaveRegisters')
|
|
|
+ );
|
|
|
+ tvarspez : array[0..2] of string[5]=('Value','Const','Var ');
|
|
|
+var
|
|
|
+ proctypeoption : tproctypeoption;
|
|
|
+ proccalloptions : tproccalloptions;
|
|
|
+ procoptions : tprocoptions;
|
|
|
+ i,params : longint;
|
|
|
+ first : boolean;
|
|
|
+begin
|
|
|
+ write(space,' Return type : ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Fpu used : ',ppufile^.getbyte);
|
|
|
+ proctypeoption:=tproctypeoption(ppufile^.getlongint);
|
|
|
+ if proctypeoption<>potype_none then
|
|
|
+ begin
|
|
|
+ write(space,' TypeOption : ');
|
|
|
+ first:=true;
|
|
|
+ for i:=1to proctypeopts do
|
|
|
+ if (proctypeopt[i].mask=proctypeoption) then
|
|
|
+ begin
|
|
|
+ if first then
|
|
|
+ first:=false
|
|
|
+ else
|
|
|
+ write(', ');
|
|
|
+ write(proctypeopt[i].str);
|
|
|
+ end;
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+ ppufile^.getsmallset(proccalloptions);
|
|
|
+ if proccalloptions<>[] then
|
|
|
+ begin
|
|
|
+ write(space,' CallOptions : ');
|
|
|
+ first:=true;
|
|
|
+ for i:=1to proccallopts do
|
|
|
+ if (proccallopt[i].mask in proccalloptions) then
|
|
|
+ begin
|
|
|
+ if first then
|
|
|
+ first:=false
|
|
|
+ else
|
|
|
+ write(', ');
|
|
|
+ write(proccallopt[i].str);
|
|
|
+ end;
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+ ppufile^.getsmallset(procoptions);
|
|
|
+ if procoptions<>[] then
|
|
|
+ begin
|
|
|
+ write(space,' Options : ');
|
|
|
+ first:=true;
|
|
|
+ for i:=1to procopts do
|
|
|
+ if (procopt[i].mask in procoptions) then
|
|
|
+ begin
|
|
|
+ if first then
|
|
|
+ first:=false
|
|
|
+ else
|
|
|
+ write(', ');
|
|
|
+ write(procopt[i].str);
|
|
|
+ end;
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+ params:=ppufile^.getword;
|
|
|
+ writeln(space,' Nr of parameters : ',params);
|
|
|
+ if params>0 then
|
|
|
+ begin
|
|
|
+ repeat
|
|
|
+ write(space,' - ',tvarspez[ppufile^.getbyte],' : ');
|
|
|
+ readtype;
|
|
|
+ write(space,' Default : ');
|
|
|
+ readsymref;
|
|
|
+ dec(params);
|
|
|
+ until params=0;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure readcommonsym(const s:string);
|
|
|
+type
|
|
|
+ tsymoption=(sp_none,
|
|
|
+ sp_public,
|
|
|
+ sp_private,
|
|
|
+ sp_published,
|
|
|
+ sp_protected,
|
|
|
+ sp_forwarddef,
|
|
|
+ sp_static,
|
|
|
+ sp_primary_typesym { this is for typesym, to know who is the primary symbol of a def }
|
|
|
+ );
|
|
|
+ tsymoptions=set of tsymoption;
|
|
|
+ tsymopt=record
|
|
|
+ mask : tsymoption;
|
|
|
+ str : string[30];
|
|
|
+ end;
|
|
|
+const
|
|
|
+ symopts=7;
|
|
|
+ symopt : array[1..symopts] of tsymopt=(
|
|
|
+ (mask:sp_public; str:'Public'),
|
|
|
+ (mask:sp_private; str:'Private'),
|
|
|
+ (mask:sp_published; str:'Published'),
|
|
|
+ (mask:sp_protected; str:'Protected'),
|
|
|
+ (mask:sp_forwarddef; str:'ForwardDef'),
|
|
|
+ (mask:sp_static; str:'Static'),
|
|
|
+ (mask:sp_primary_typesym;str:'PrimaryTypeSym')
|
|
|
+ );
|
|
|
+var
|
|
|
+ symoptions : tsymoptions;
|
|
|
+ i : longint;
|
|
|
+ first : boolean;
|
|
|
+begin
|
|
|
+ writeln(space,'** Symbol Nr. ',ppufile^.getword,' **');
|
|
|
+ writeln(space,s,ppufile^.getstring);
|
|
|
+ ppufile^.getsmallset(symoptions);
|
|
|
+ if symoptions<>[] then
|
|
|
+ begin
|
|
|
+ write(space,' File Pos: ');
|
|
|
+ readposinfo;
|
|
|
+ write(space,' SymOptions: ');
|
|
|
+ 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;
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure readcommondef(const s:string);
|
|
|
+begin
|
|
|
+ writeln(space,'** Definition Nr. ',ppufile^.getword,' **');
|
|
|
+ writeln(space,s);
|
|
|
+ write (space,' Type symbol : ');
|
|
|
+ readsymref;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read Symbols Part
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+procedure readsymbols;
|
|
|
+Const
|
|
|
+ vo_is_C_var = 2;
|
|
|
+Type
|
|
|
+ absolutetyp = (tovar,toasm,toaddr);
|
|
|
+ tconsttyp = (constnone,
|
|
|
+ constord,conststring,constreal,constbool,
|
|
|
+ constint,constchar,constset,constpointer,constnil,
|
|
|
+ constresourcestring
|
|
|
+ );
|
|
|
+var
|
|
|
+ b : byte;
|
|
|
+ pc : pchar;
|
|
|
+ totalsyms,
|
|
|
+ symcnt,
|
|
|
+ i,j,len : longint;
|
|
|
+ l1,l2 : longint;
|
|
|
+begin
|
|
|
+ symcnt:=1;
|
|
|
+ with ppufile^ do
|
|
|
+ begin
|
|
|
+ if space<>'' then
|
|
|
+ Writeln(space,'-----------------------------');
|
|
|
+ if readentry=ibstartsyms then
|
|
|
+ begin
|
|
|
+ totalsyms:=getlongint;
|
|
|
+ Writeln(space,'Number of symbols : ',totalsyms);
|
|
|
+ Writeln(space,'Symtable datasize : ',getlongint);
|
|
|
+ Writeln(space,'Symtable alignment: ',getlongint);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ totalsyms:=-1;
|
|
|
+ Writeln('!! ibstartsym not found');
|
|
|
+ end;
|
|
|
+ repeat
|
|
|
+ b:=readentry;
|
|
|
+ if not (b in [iberror,ibendsyms]) then
|
|
|
+ inc(symcnt);
|
|
|
+ case b of
|
|
|
+
|
|
|
+ ibunitsym :
|
|
|
+ readcommonsym('Unit symbol ');
|
|
|
+
|
|
|
+ iblabelsym :
|
|
|
+ readcommonsym('Label symbol ');
|
|
|
+
|
|
|
+ ibtypesym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Type symbol ');
|
|
|
+ write(space,' Result Type: ');
|
|
|
+ readtype;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibprocsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Procedure symbol ');
|
|
|
+ write(space,' Definition: ');
|
|
|
+ readdefref;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibconstsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Constant symbol ');
|
|
|
+ b:=getbyte;
|
|
|
+ case tconsttyp(b) of
|
|
|
+ constord :
|
|
|
+ begin
|
|
|
+ write (space,'OrdinalType: ');
|
|
|
+ readtype;
|
|
|
+ writeln (space,' Value: ',getlongint)
|
|
|
+ end;
|
|
|
+ constpointer :
|
|
|
+ begin
|
|
|
+ write (space,' Pointer Type: ');
|
|
|
+ readtype;
|
|
|
+ writeln (space,' Value: ',getlongint)
|
|
|
+ end;
|
|
|
+ conststring,
|
|
|
+ constresourcestring :
|
|
|
+ begin
|
|
|
+ len:=getlongint;
|
|
|
+ getmem(pc,len+1);
|
|
|
+ getdata(pc^,len);
|
|
|
+ writeln(space,' Length: ',len);
|
|
|
+ writeln(space,' Value: "',pc,'"');
|
|
|
+ freemem(pc,len+1);
|
|
|
+ if tconsttyp(b)=constresourcestring then
|
|
|
+ writeln(space,' Index: ',getlongint);
|
|
|
+ end;
|
|
|
+ constreal :
|
|
|
+ writeln(space,' Value: ',getreal);
|
|
|
+ constbool :
|
|
|
+ if getlongint<>0 then
|
|
|
+ writeln (space,' Value : True')
|
|
|
+ else
|
|
|
+ writeln (space,' Value: False');
|
|
|
+ constint :
|
|
|
+ begin
|
|
|
+ l1:=getlongint;
|
|
|
+ l2:=getlongint;
|
|
|
+ writeln(space,' Value: ',int64(l2 shl 32) or l1);
|
|
|
+ end;
|
|
|
+ constchar :
|
|
|
+ writeln(space,' Value: "'+chr(getlongint)+'"');
|
|
|
+ constset :
|
|
|
+ begin
|
|
|
+ write (space,' Set Type: ');
|
|
|
+ readtype;
|
|
|
+ for i:=1to 4 do
|
|
|
+ begin
|
|
|
+ write (space,' Value: ');
|
|
|
+ for j:=1to 8 do
|
|
|
+ begin
|
|
|
+ if j>1 then
|
|
|
+ write(',');
|
|
|
+ write(hexb(getbyte));
|
|
|
+ end;
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ else
|
|
|
+ Writeln ('!! Invalid unit format : Invalid const type encountered: ',b);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibvarsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Variable symbol ');
|
|
|
+ writeln(space,' Type: ',getbyte);
|
|
|
+ if read_member then
|
|
|
+ writeln(space,' Address: ',getlongint);
|
|
|
+ write (space,' Var Type: ');
|
|
|
+ readtype;
|
|
|
+ i:=getlongint;
|
|
|
+ writeln(space,' Options: ',i);
|
|
|
+ if (i and vo_is_C_var)<>0 then
|
|
|
+ writeln(space,' Mangledname: ',getstring);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibenumsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Enumeration symbol ');
|
|
|
+ write (space,' Definition: ');
|
|
|
+ readdefref;
|
|
|
+ writeln(space,' Value: ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibsyssym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Internal system symbol ');
|
|
|
+ writeln(space,' Internal Nr: ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibtypedconstsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Typed constant ');
|
|
|
+ write (space,' Constant Type: ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Label: ',getstring);
|
|
|
+ writeln(space,' ReallyConst: ',(getbyte<>0));
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibabsolutesym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Absolute variable symbol ');
|
|
|
+ writeln(space,' Type: ',getbyte);
|
|
|
+ if read_member then
|
|
|
+ writeln(space,' Address: ',getlongint);
|
|
|
+ write (space,' Var Type: ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Options: ',getlongint);
|
|
|
+ Write (space,' Relocated to ');
|
|
|
+ b:=getbyte;
|
|
|
+ case absolutetyp(b) of
|
|
|
+ tovar :
|
|
|
+ Writeln('Name : ',getstring);
|
|
|
+ toasm :
|
|
|
+ Writeln('Assembler name : ',getstring);
|
|
|
+ toaddr :
|
|
|
+ begin
|
|
|
+ Write('Address : ',getlongint);
|
|
|
+ WriteLn(' (Far: ',getbyte<>0,')');
|
|
|
+ end;
|
|
|
+ else
|
|
|
+ Writeln ('!! Invalid unit format : Invalid absolute type encountered: ',b);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibpropertysym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Property ');
|
|
|
+ i:=getlongint;
|
|
|
+ writeln(space,' PropOptions: ',i);
|
|
|
+ if (i and 32)>0 then
|
|
|
+ begin
|
|
|
+ write (space,'OverrideProp: ');
|
|
|
+ readsymref;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ write (space,' Prop Type: ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Index: ',getlongint);
|
|
|
+ writeln(space,' Default: ',getlongint);
|
|
|
+ write (space,' Index Type: ');
|
|
|
+ readtype;
|
|
|
+ write (space,' Readaccess: ');
|
|
|
+ readsymlist(space+' Sym: ');
|
|
|
+ write (space,' Writeaccess: ');
|
|
|
+ readsymlist(space+' Sym: ');
|
|
|
+ write (space,'Storedaccess: ');
|
|
|
+ readsymlist(space+' Sym: ');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibfuncretsym :
|
|
|
+ begin
|
|
|
+ readcommonsym('Func return value ');
|
|
|
+ write (space,' Return Type: ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Address: ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ iberror :
|
|
|
+ begin
|
|
|
+ Writeln('!! Error in PPU');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibendsyms :
|
|
|
+ break;
|
|
|
+
|
|
|
+ else
|
|
|
+ WriteLn('!! Skipping unsupported PPU Entry in Symbols: ',b);
|
|
|
+ end;
|
|
|
+ if not EndOfEntry then
|
|
|
+ Writeln('!! Entry has more information stored');
|
|
|
+ until false;
|
|
|
+ if (totalsyms<>-1) and (symcnt-1<>totalsyms) then
|
|
|
+ Writeln('!! Only read ',symcnt-1,' of ',totalsyms,' symbols');
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read defintions Part
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+procedure readdefinitions(start_read : boolean);
|
|
|
+type
|
|
|
+ tsettype = (normset,smallset,varset);
|
|
|
+ tbasetype = (
|
|
|
+ uauto,uvoid,uchar,
|
|
|
+ u8bit,u16bit,u32bit,
|
|
|
+ s8bit,s16bit,s32bit,
|
|
|
+ bool8bit,bool16bit,bool32bit,
|
|
|
+ u64bit,s64bit,uwidechar
|
|
|
+ );
|
|
|
+ tobjectdeftype = (odt_none,
|
|
|
+ odt_class,
|
|
|
+ odt_object,
|
|
|
+ odt_interfacecom,
|
|
|
+ odt_interfacecorba,
|
|
|
+ odt_cppclass
|
|
|
+ );
|
|
|
+var
|
|
|
+ b : byte;
|
|
|
+ oldread_member : boolean;
|
|
|
+ totaldefs,l,j,
|
|
|
+ defcnt : longint;
|
|
|
+begin
|
|
|
+ defcnt:=0;
|
|
|
+ with ppufile^ do
|
|
|
+ begin
|
|
|
+ if space<>'' then
|
|
|
+ Writeln(space,'-----------------------------');
|
|
|
+ if not start_read then
|
|
|
+ if readentry=ibstartdefs then
|
|
|
+ begin
|
|
|
+ totaldefs:=getlongint;
|
|
|
+ Writeln(space,'Number of definitions: ',totaldefs);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ totaldefs:=-1;
|
|
|
+ Writeln('!! ibstartdef not found');
|
|
|
+ end;
|
|
|
+ repeat
|
|
|
+ b:=readentry;
|
|
|
+ if not (b in [iberror,ibenddefs]) then
|
|
|
+ inc(defcnt);
|
|
|
+ case b of
|
|
|
+
|
|
|
+ ibpointerdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Pointer definition');
|
|
|
+ write (space,' Pointed Type : ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Is Far : ',(getbyte<>0));
|
|
|
+ end;
|
|
|
+
|
|
|
+ iborddef :
|
|
|
+ begin
|
|
|
+ readcommondef('Ordinal definition');
|
|
|
+ write (space,' Base type : ');
|
|
|
+ b:=getbyte;
|
|
|
+ case tbasetype(b) of
|
|
|
+ uauto : writeln('uauto');
|
|
|
+ uvoid : writeln('uvoid');
|
|
|
+ uchar : writeln('uchar');
|
|
|
+ u8bit : writeln('u8bit');
|
|
|
+ u16bit : writeln('u16bit');
|
|
|
+ u32bit : writeln('s32bit');
|
|
|
+ s8bit : writeln('s8bit');
|
|
|
+ s16bit : writeln('s16bit');
|
|
|
+ s32bit : writeln('s32bit');
|
|
|
+ bool8bit : writeln('bool8bit');
|
|
|
+ bool16bit : writeln('bool16bit');
|
|
|
+ bool32bit : writeln('bool32bit');
|
|
|
+ u64bit : writeln('u64bit');
|
|
|
+ s64bit : writeln('s64bit');
|
|
|
+ uwidechar : writeln('uwidechar');
|
|
|
+ else writeln('!! Warning: Invalid base type ',b);
|
|
|
+ end;
|
|
|
+ writeln(space,' Range : ',getlongint,' to ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibfloatdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Float definition');
|
|
|
+ writeln(space,' Float type : ',getbyte);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibarraydef :
|
|
|
+ begin
|
|
|
+ readcommondef('Array definition');
|
|
|
+ write (space,' Element type : ');
|
|
|
+ readtype;
|
|
|
+ write (space,' Range Type : ');
|
|
|
+ readtype;
|
|
|
+ writeln(space,' Range : ',getlongint,' to ',getlongint);
|
|
|
+ writeln(space,' Is Constructor : ',(getbyte<>0));
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibprocdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Procedure definition');
|
|
|
+ read_abstract_proc_def;
|
|
|
+ writeln(space,' Used Register : ',getbyte);
|
|
|
+ writeln(space,' Mangled name : ',getstring);
|
|
|
+ writeln(space,' Number : ',getlongint);
|
|
|
+ write (space,' Next : ');
|
|
|
+ readdefref;
|
|
|
+ write (space,' Class : ');
|
|
|
+ readdefref;
|
|
|
+ write (space,' File Pos : ');
|
|
|
+ readposinfo;
|
|
|
+ space:=' '+space;
|
|
|
+ { parast }
|
|
|
+ readdefinitions(false);
|
|
|
+ readsymbols;
|
|
|
+ { localst }
|
|
|
+ {readdefinitions(false);
|
|
|
+ readsymbols;}
|
|
|
+ delete(space,1,4);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibprocvardef :
|
|
|
+ begin
|
|
|
+ readcommondef('Procedural type (ProcVar) definition');
|
|
|
+ read_abstract_proc_def;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibshortstringdef :
|
|
|
+ begin
|
|
|
+ readcommondef('ShortString definition');
|
|
|
+ writeln(space,' Length : ',getbyte);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibwidestringdef :
|
|
|
+ begin
|
|
|
+ readcommondef('WideString definition');
|
|
|
+ writeln(space,' Length : ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibansistringdef :
|
|
|
+ begin
|
|
|
+ readcommondef('AnsiString definition');
|
|
|
+ writeln(space,' Length : ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ iblongstringdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Longstring definition');
|
|
|
+ writeln(space,' Length : ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibrecorddef :
|
|
|
+ begin
|
|
|
+ readcommondef('Record definition');
|
|
|
+ writeln(space,' Size : ',getlongint);
|
|
|
+ {read the record definitions and symbols}
|
|
|
+ space:=' '+space;
|
|
|
+ oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ readdefinitions(false);
|
|
|
+ readsymbols;
|
|
|
+ read_member:=oldread_member;
|
|
|
+ Delete(space,1,4);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibobjectdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Object/Class definition');
|
|
|
+ b:=getbyte;
|
|
|
+ write (space,' Type : ');
|
|
|
+ case tobjectdeftype(b) of
|
|
|
+ odt_class : writeln('class');
|
|
|
+ odt_object : writeln('object');
|
|
|
+ odt_interfacecom : writeln('interfacecom');
|
|
|
+ odt_interfacecorba : writeln('interfacecorba');
|
|
|
+ odt_cppclass : writeln('cppclass');
|
|
|
+ else writeln('!! Warning: Invalid object type ',b);
|
|
|
+ end;
|
|
|
+ writeln(space,' Size : ',getlongint);
|
|
|
+ writeln(space,' Vmt offset : ',getlongint);
|
|
|
+ writeln(space,' Name of Class : ',getstring);
|
|
|
+ write(space, ' Ancestor Class : ');
|
|
|
+ readdefref;
|
|
|
+ writeln(space,' Options : ',getlongint);
|
|
|
+ writeln(space,' Has RTTI : ',(getbyte<>0));
|
|
|
+
|
|
|
+ if tobjectdeftype(b) in [odt_interfacecom,odt_interfacecorba] then
|
|
|
+ begin
|
|
|
+ writeln(space,' GUID Valid : ',(getbyte<>0));
|
|
|
+ { IIDGUID }
|
|
|
+ for j:=1to 16 do
|
|
|
+ getbyte;
|
|
|
+ writeln(space,' IID String : ',getstring);
|
|
|
+ writeln(space,' Last VTable idx : ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if tobjectdeftype(b) in [odt_class,odt_interfacecorba] then
|
|
|
+ begin
|
|
|
+ l:=getlongint;
|
|
|
+ writeln(space,' Impl Intf Count : ',l);
|
|
|
+ for j:=1 to l do
|
|
|
+ begin
|
|
|
+ write (space,' - Definition : ');
|
|
|
+ readdefref;
|
|
|
+ writeln(space,' IOffset : ',getlongint);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ {read the record definitions and symbols}
|
|
|
+ space:=' '+space;
|
|
|
+ oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ readdefinitions(false);
|
|
|
+ readsymbols;
|
|
|
+ read_member:=oldread_member;
|
|
|
+ Delete(space,1,4);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibfiledef :
|
|
|
+ begin
|
|
|
+ ReadCommonDef('File definition');
|
|
|
+ write (space,' Type : ');
|
|
|
+ case getbyte of
|
|
|
+ 0 : writeln('Text');
|
|
|
+ 1 : begin
|
|
|
+ writeln('Typed');
|
|
|
+ write (space,' File of Type : ');
|
|
|
+ Readtype;
|
|
|
+ end;
|
|
|
+ 2 : writeln('Untyped');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibformaldef :
|
|
|
+ readcommondef('Generic Definition (void-typ)');
|
|
|
+
|
|
|
+ ibenumdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Enumeration type definition');
|
|
|
+ write(space,'Base enumeration type : ');
|
|
|
+ readdefref;
|
|
|
+ writeln(space,' Smallest element : ',getlongint);
|
|
|
+ writeln(space,' Largest element : ',getlongint);
|
|
|
+ writeln(space,' Size : ',getlongint);
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibclassrefdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Class reference definition');
|
|
|
+ write (space,' Pointed Type : ');
|
|
|
+ readtype;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibsetdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Set definition');
|
|
|
+ write (space,' Element type : ');
|
|
|
+ readtype;
|
|
|
+ b:=getbyte;
|
|
|
+ case tsettype(b) of
|
|
|
+ smallset : writeln(space,' Set with 32 Elements');
|
|
|
+ normset : writeln(space,' Set with 256 Elements');
|
|
|
+ varset : writeln(space,' Set with ',getlongint,' Elements');
|
|
|
+ else writeln('!! Warning: Invalid set type ',b);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+
|
|
|
+ ibvariantdef :
|
|
|
+ begin
|
|
|
+ readcommondef('Variant definition');
|
|
|
+ end;
|
|
|
+
|
|
|
+ iberror :
|
|
|
+ begin
|
|
|
+ Writeln('!! Error in PPU');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibenddefs :
|
|
|
+ break;
|
|
|
+
|
|
|
+ else
|
|
|
+ WriteLn('!! Skipping unsupported PPU Entry in definitions: ',b);
|
|
|
+ end;
|
|
|
+ if not EndOfEntry then
|
|
|
+ Writeln('!! Entry has more information stored');
|
|
|
+ until false;
|
|
|
+ if (totaldefs<>-1) and (defcnt<>totaldefs) then
|
|
|
+ Writeln('!! Only read ',defcnt,' of ',totaldefs,' definitions');
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read General Part
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+procedure readinterface;
|
|
|
+var
|
|
|
+ b : byte;
|
|
|
+ sourcenumber,
|
|
|
+ unitnumber : word;
|
|
|
+ ucrc,uintfcrc : longint;
|
|
|
+begin
|
|
|
+ with ppufile^ do
|
|
|
+ begin
|
|
|
+ repeat
|
|
|
+ b:=readentry;
|
|
|
+ case b of
|
|
|
+
|
|
|
+ ibmodulename :
|
|
|
+ Writeln('Module Name: ',getstring);
|
|
|
+
|
|
|
+ ibsourcefiles :
|
|
|
+ begin
|
|
|
+ sourcenumber:=1;
|
|
|
+ while not EndOfEntry do
|
|
|
+ begin
|
|
|
+ Writeln('Source file ',sourcenumber,' : ',getstring);
|
|
|
+ inc(sourcenumber);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibusedmacros :
|
|
|
+ begin
|
|
|
+ while not EndOfEntry do
|
|
|
+ begin
|
|
|
+ Write('Conditional ',getstring);
|
|
|
+ b:=getbyte;
|
|
|
+ if boolean(b)=true then
|
|
|
+ write(' defined at startup')
|
|
|
+ else
|
|
|
+ write(' not defined at startup');
|
|
|
+ b:=getbyte;
|
|
|
+ if boolean(b)=true then
|
|
|
+ writeln(' was used')
|
|
|
+ else
|
|
|
+ writeln;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ ibloadunit :
|
|
|
+ begin
|
|
|
+ unitnumber:=1;
|
|
|
+ while not EndOfEntry do
|
|
|
+ begin
|
|
|
+ write('Uses unit: ',getstring,' (Number: ',unitnumber,')');
|
|
|
+ ucrc:=getlongint;
|
|
|
+ uintfcrc:=getlongint;
|
|
|
+ write(' (Crc: ',ucrc,', IntfcCrc: ',uintfcrc,')');
|
|
|
+ if getbyte<>0 then
|
|
|
+ writeln(' (interface)')
|
|
|
+ else
|
|
|
+ writeln(' (implementation)');
|
|
|
+ inc(unitnumber);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ iblinkunitofiles :
|
|
|
+ ReadLinkContainer('Link unit object file: ');
|
|
|
+
|
|
|
+ iblinkunitstaticlibs :
|
|
|
+ ReadLinkContainer('Link unit static lib: ');
|
|
|
+
|
|
|
+ iblinkunitsharedlibs :
|
|
|
+ ReadLinkContainer('Link unit shared lib: ');
|
|
|
+
|
|
|
+ iblinkotherofiles :
|
|
|
+ ReadLinkContainer('Link other object file: ');
|
|
|
+
|
|
|
+ iblinkotherstaticlibs :
|
|
|
+ ReadLinkContainer('Link other static lib: ');
|
|
|
+
|
|
|
+ iblinkothersharedlibs :
|
|
|
+ ReadLinkContainer('Link other shared lib: ');
|
|
|
+
|
|
|
+ iberror :
|
|
|
+ begin
|
|
|
+ Writeln('Error in PPU');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ ibendinterface :
|
|
|
+ break;
|
|
|
+
|
|
|
+ else
|
|
|
+ WriteLn('!! Skipping unsupported PPU Entry in General Part: ',b);
|
|
|
+ end;
|
|
|
+ until false;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read Implementation Part
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+procedure readimplementation;
|
|
|
+var
|
|
|
+ b : byte;
|
|
|
+begin
|
|
|
+ with ppufile^ do
|
|
|
+ begin
|
|
|
+ repeat
|
|
|
+ b:=readentry;
|
|
|
+ case b of
|
|
|
+ iberror :
|
|
|
+ begin
|
|
|
+ Writeln('Error in PPU');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ ibendimplementation :
|
|
|
+ break;
|
|
|
+ else
|
|
|
+ WriteLn('!! Skipping unsupported PPU Entry in Implementation: ',b);
|
|
|
+ end;
|
|
|
+ until false;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Read Browser Part
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+procedure readbrowser;
|
|
|
+var
|
|
|
+ b : byte;
|
|
|
+const indent : string = '';
|
|
|
+begin
|
|
|
+ Writeln(indent,'Start of symtable browser');
|
|
|
+ indent:=indent+'**';
|
|
|
+ with ppufile^ do
|
|
|
+ begin
|
|
|
+ repeat
|
|
|
+ b:=readentry;
|
|
|
+ case b of
|
|
|
+ ibbeginsymtablebrowser :
|
|
|
+ { here we must read object and record symtables !! }
|
|
|
+ begin
|
|
|
+ indent:=indent+' ';
|
|
|
+ Writeln(indent,'Record/Object symtable');
|
|
|
+ readbrowser;
|
|
|
+ Indent:=Copy(Indent,1,Length(Indent)-2);
|
|
|
+ end;
|
|
|
+ ibsymref : begin
|
|
|
+ readsymref;
|
|
|
+ readref;
|
|
|
+ end;
|
|
|
+ ibdefref : begin
|
|
|
+ readdefref;
|
|
|
+ readref;
|
|
|
+ if (ppufile^.header.flags and uf_local_browser)<>0 then
|
|
|
+ begin
|
|
|
+ { parast and localst }
|
|
|
+ indent:=indent+' ';
|
|
|
+ Writeln(indent,'Parasymtable for function');
|
|
|
+ readdefinitions(false);
|
|
|
+ readsymbols;
|
|
|
+ b:=ppufile^.readentry;
|
|
|
+ if b=ibbeginsymtablebrowser then
|
|
|
+ readbrowser;
|
|
|
+ Writeln(indent,'Localsymtable for function');
|
|
|
+ readdefinitions(false);
|
|
|
+ readsymbols;
|
|
|
+ b:=ppufile^.readentry;
|
|
|
+ if b=ibbeginsymtablebrowser then
|
|
|
+ readbrowser;
|
|
|
+ Indent:=Copy(Indent,1,Length(Indent)-2);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ iberror : begin
|
|
|
+ Writeln('Error in PPU');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ ibendsymtablebrowser : break;
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ WriteLn('!! Skipping unsupported PPU Entry in Browser: ',b);
|
|
|
+ Halt;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ until false;
|
|
|
+ end;
|
|
|
+ Indent:=Copy(Indent,1,Length(Indent)-2);
|
|
|
+ Writeln(Indent,'End of symtable browser');
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+procedure dofile (filename : string);
|
|
|
+var
|
|
|
+ b,unitindex : byte;
|
|
|
+begin
|
|
|
+{ reset }
|
|
|
+ space:='';
|
|
|
+{ fix filename }
|
|
|
+ if pos('.',filename)=0 then
|
|
|
+ filename:=filename+'.ppu';
|
|
|
+ ppufile:=new(pppufile,Init(filename));
|
|
|
+ if not ppufile^.open then
|
|
|
+ begin
|
|
|
+ writeln ('IO-Error when opening : ',filename,', Skipping');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+{ PPU File is open, check for PPU Id }
|
|
|
+ if not ppufile^.CheckPPUID then
|
|
|
+ begin
|
|
|
+ writeln(Filename,' : Not a valid PPU file, Skipping');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+{ Check PPU Version }
|
|
|
+ Writeln('Analyzing ',filename,' (v',ppufile^.GetPPUVersion,')');
|
|
|
+ if ppufile^.GetPPUVersion<16 then
|
|
|
+ begin
|
|
|
+ writeln(Filename,' : Old PPU Formats (<v16) are not supported, Skipping');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+{ Write PPU Header Information }
|
|
|
+ if (verbose and v_header)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Header');
|
|
|
+ Writeln('-------');
|
|
|
+ with ppufile^.header do
|
|
|
+ begin
|
|
|
+ Writeln('Compiler version : ',hi(ppufile^.header.compiler and $ff),'.',lo(ppufile^.header.compiler));
|
|
|
+ WriteLn('Target processor : ',Cpu2Str(cpu));
|
|
|
+ WriteLn('Target operating system : ',Target2Str(target));
|
|
|
+ Writeln('Unit flags : ',PPUFlags2Str(flags));
|
|
|
+ Writeln('FileSize (w/o header) : ',size);
|
|
|
+ Writeln('Checksum : ',checksum);
|
|
|
+ Writeln('Interface Checksum : ',interface_checksum);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+{read the general stuff}
|
|
|
+ if (verbose and v_interface)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Interface section');
|
|
|
+ Writeln('------------------');
|
|
|
+ readinterface;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ppufile^.skipuntilentry(ibendinterface);
|
|
|
+{read the definitions}
|
|
|
+ if (verbose and v_defs)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Interface definitions');
|
|
|
+ Writeln('----------------------');
|
|
|
+ readdefinitions(false);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ppufile^.skipuntilentry(ibenddefs);
|
|
|
+{read the symbols}
|
|
|
+ if (verbose and v_syms)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Interface Symbols');
|
|
|
+ Writeln('------------------');
|
|
|
+ readsymbols;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ppufile^.skipuntilentry(ibendsyms);
|
|
|
+{read the implementation stuff}
|
|
|
+{ Not used at the moment (PFV)
|
|
|
+ if (verbose and v_implementation)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Implementation section');
|
|
|
+ Writeln('-----------------------');
|
|
|
+ readimplementation;
|
|
|
+ end
|
|
|
+ else}
|
|
|
+ ppufile^.skipuntilentry(ibendimplementation);
|
|
|
+{read the static browser units stuff}
|
|
|
+ if (ppufile^.header.flags and uf_local_browser)<>0 then
|
|
|
+ begin
|
|
|
+ if (verbose and v_defs)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Static definitions');
|
|
|
+ Writeln('----------------------');
|
|
|
+ readdefinitions(false);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ppufile^.skipuntilentry(ibenddefs);
|
|
|
+ {read the symbols}
|
|
|
+ if (verbose and v_syms)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Static Symbols');
|
|
|
+ Writeln('------------------');
|
|
|
+ readsymbols;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+{read the browser units stuff}
|
|
|
+ if (ppufile^.header.flags and uf_has_browser)<>0 then
|
|
|
+ begin
|
|
|
+ if (verbose and v_browser)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Browser section');
|
|
|
+ Writeln('---------------');
|
|
|
+ UnitIndex:=0;
|
|
|
+ repeat
|
|
|
+ b:=ppufile^.readentry;
|
|
|
+ if b = ibendbrowser then break;
|
|
|
+ if b=ibbeginsymtablebrowser then
|
|
|
+ begin
|
|
|
+ Writeln('Unit ',UnitIndex);
|
|
|
+ readbrowser;
|
|
|
+ Inc(UnitIndex);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ Writeln('Wrong end browser entry ',b,' should be ',ibendbrowser);
|
|
|
+ until false;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+{read the static browser units stuff}
|
|
|
+ if (ppufile^.header.flags and uf_local_browser)<>0 then
|
|
|
+ begin
|
|
|
+ if (verbose and v_browser)<>0 then
|
|
|
+ begin
|
|
|
+ Writeln;
|
|
|
+ Writeln('Static browser section');
|
|
|
+ Writeln('---------------');
|
|
|
+ b:=ppufile^.readentry;
|
|
|
+ if b=ibbeginsymtablebrowser then
|
|
|
+ begin
|
|
|
+ Writeln('Unit ',UnitIndex);
|
|
|
+ readbrowser;
|
|
|
+ Inc(UnitIndex);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ Writeln('Wrong end browser entry ',b,' should be ',ibendbrowser);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+{shutdown ppufile}
|
|
|
+ ppufile^.close;
|
|
|
+ dispose(ppufile,done);
|
|
|
+ Writeln;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+procedure help;
|
|
|
+begin
|
|
|
+ writeln('usage: ppudump [options] <filename1> <filename2>...');
|
|
|
+ writeln;
|
|
|
+ writeln('[options] can be:');
|
|
|
+ writeln(' -V<verbose> Set verbosity to <verbose>');
|
|
|
+ writeln(' H - Show header info');
|
|
|
+ writeln(' I - Show interface');
|
|
|
+ writeln(' M - Show implementation');
|
|
|
+ writeln(' S - Show interface symbols');
|
|
|
+ writeln(' D - Show interface definitions');
|
|
|
+ writeln(' B - Show browser info');
|
|
|
+ writeln(' A - Show all');
|
|
|
+ writeln(' -? This helpscreen');
|
|
|
+ halt;
|
|
|
+end;
|
|
|
+
|
|
|
+var
|
|
|
+ startpara,
|
|
|
+ nrfile,i : longint;
|
|
|
+ para : string;
|
|
|
+begin
|
|
|
+ writeln(Title+' '+Version);
|
|
|
+ writeln(Copyright);
|
|
|
+ writeln;
|
|
|
+ if paramcount<1 then
|
|
|
+ begin
|
|
|
+ writeln('usage: dumpppu [options] <filename1> <filename2>...');
|
|
|
+ halt(1);
|
|
|
+ end;
|
|
|
+{ 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
|
|
|
+ 'V' : begin
|
|
|
+ verbose:=0;
|
|
|
+ for i:=3to 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;
|
|
|
+ 'B' : verbose:=verbose or v_browser;
|
|
|
+ 'A' : verbose:=verbose or v_all;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ '?' : help;
|
|
|
+ end;
|
|
|
+ inc(startpara);
|
|
|
+ end;
|
|
|
+{ process files }
|
|
|
+ for nrfile:=startpara to paramcount do
|
|
|
+ dofile (paramstr(nrfile));
|
|
|
+ if has_errors then
|
|
|
+ Halt(1);
|
|
|
+end.
|
|
|
+{
|
|
|
+ $Log$
|
|
|
+ Revision 1.1 2001-04-25 22:40:07 peter
|
|
|
+ * compiler dependent utils in utils/ subdir
|
|
|
+
|
|
|
+ Revision 1.5 2001/04/10 21:21:41 peter
|
|
|
+ * variantdef support
|
|
|
+ * propertysym fixed
|
|
|
+
|
|
|
+ Revision 1.4 2001/04/04 22:42:59 peter
|
|
|
+ * updated for new objectdef with interfaces
|
|
|
+
|
|
|
+ Revision 1.3 2000/09/09 19:46:40 peter
|
|
|
+ * show dataalignment
|
|
|
+
|
|
|
+ Revision 1.2 2000/08/13 12:58:06 peter
|
|
|
+ * updated for ppu additions
|
|
|
+
|
|
|
+ Revision 1.1 2000/07/13 10:16:22 michael
|
|
|
+ + Initial import
|
|
|
+
|
|
|
+ Revision 1.15 2000/07/04 19:05:54 peter
|
|
|
+ * be optimistic: version 1.00 for some utils
|
|
|
+
|
|
|
+ Revision 1.14 2000/02/09 16:44:14 peter
|
|
|
+ * log truncated
|
|
|
+
|
|
|
+ Revision 1.13 2000/01/23 16:34:36 peter
|
|
|
+ * updated for new aktlocalindex
|
|
|
+
|
|
|
+ Revision 1.12 2000/01/07 16:46:03 daniel
|
|
|
+ * copyright 2000
|
|
|
+
|
|
|
+ Revision 1.11 1999/11/30 10:35:37 peter
|
|
|
+ * support new readtype
|
|
|
+
|
|
|
+ Revision 1.10 1999/11/08 14:06:45 florian
|
|
|
+ + indexref of propertysym is handle too now
|
|
|
+
|
|
|
+ Revision 1.9 1999/08/31 16:07:37 pierre
|
|
|
+ + support for writeusedmacros
|
|
|
+
|
|
|
+ Revision 1.8 1999/08/15 10:47:14 peter
|
|
|
+ * updates for new options
|
|
|
+
|
|
|
+ Revision 1.7 1999/08/13 21:25:35 peter
|
|
|
+ * updated flags
|
|
|
+
|
|
|
+ Revision 1.6 1999/07/27 23:45:29 peter
|
|
|
+ * updated for typesym writing
|
|
|
+
|
|
|
+}
|
peter