paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-11 18:06:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

no message

Browse Source
This commit is contained in:
florian 2004-12-27 15:55:32 +00:00
parent 5fb0678de2
commit e9676f56b8
1 changed files with 41 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
tests/test/dumpclass.pp
View File

@ -4,9 +4,9 @@ program DumpClass;
uses
Classes, SysUtils;
const
VMT_COUNT = 100;
VMT_COUNT = 100;
type
@ -20,32 +20,40 @@ type
Entries: packed array[0..9999999] of TMethodNameTableEntry;
end;
PMethodNameTable = ^TMethodNameTable;
TPointerArray = packed array[0..9999999] of Pointer;
PPointerArray = ^TPointerArray;
PFieldInfo = ^TFieldInfo;
TFieldInfo = packed record
FieldOffset: LongWord;
ClassTypeIndex: Word;
Name: ShortString;
end;
PFieldClassTable = ^TFieldClassTable;
TFieldClassTable = packed record
TFieldClassTable =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
Count: Word;
Entries: array[Word] of TPersistentClass;
end;
PFieldTable = ^TFieldTable;
TFieldTable = packed record
TFieldTable =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
FieldCount: Word;
ClassTable: PFieldClassTable;
{ Fields: array[Word] of TFieldInfo; Elements have variant size! }
end;
{$M+}
TMyTest = class(TObject)
TMyTest = class(TObject)
published
F1: TMyTest;
F2: TMyTest;
@ -55,7 +63,7 @@ type
{$M-}
TMyTest2 = class(TMyTest)
F3: TMyTest;
F3: TMyTest;
F4: TMyTest;
procedure P2; override;
procedure P3; virtual;
@ -65,28 +73,28 @@ type
procedure P1; virtual;
procedure P2; virtual;
end;
procedure TMyTest.P1;
procedure TMyTest.P1;
begin
end;
procedure TMyTest.P2;
procedure TMyTest.P2;
begin
end;
procedure TMyTest2.P2;
procedure TMyTest2.P2;
begin
end;
procedure TMyTest2.P3;
procedure TMyTest2.P3;
begin
end;
procedure TMyPersistent.P1;
procedure TMyPersistent.P1;
begin
end;
procedure TMyPersistent.P2;
procedure TMyPersistent.P2;
begin
end;
@ -100,7 +108,7 @@ var
Indent: String;
n, idx: Integer;
SearchAddr: Pointer;
begin
begin
WriteLn('---------------------------------------------');
WriteLn('Dump of ', AClass.ClassName);
WriteLn('---------------------------------------------');
@ -109,7 +117,7 @@ begin
begin
WriteLn(Indent, 'Processing ', AClass.Classname);
Indent := Indent + ' ';
//---
Cmnt := PPointer(Pointer(AClass) + vmtMethodTable)^;
if Cmnt <> nil
@ -117,11 +125,11 @@ begin
WriteLn(Indent, 'Method count: ', IntToStr(Cmnt^.Count));
Cvmt := Pointer(AClass) + vmtMethodStart;
for n := 0 to Cmnt^.Count - 1 do
begin
begin
Write(Indent, 'Search: ', Cmnt^.Entries[n].Name^);
SearchAddr := Cmnt^.Entries[n].Addr;
for idx := 0 to VMT_COUNT - 1 do
begin
@ -135,11 +143,11 @@ begin
WriteLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^, '" not found in "', AClass.ClassName, '"');
Break;
end;
end;
end;
end;
end;
//---
Cft := PPointer(Pointer(AClass) + vmtFieldTable)^;
if Cft <> nil
@ -147,22 +155,26 @@ begin
WriteLn(Indent, 'Field count: ', Cft^.FieldCount);
fi := @Cft^.ClassTable + SizeOf(Cft^.ClassTable);
for n := 0 to Cft^.FieldCount - 1 do
begin
begin
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
pointer(fi):=align(fi,sizeof(pointer));
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
Move(fi^.FieldOffset, FieldOffset, SizeOf(FieldOffset));
WriteLn(Indent, ' ', n, ': ', fi^.Name, ' @', FieldOffset);
fi := @fi^.name + 1 + Ord(fi^.name[0]);
end;
WriteLn(Indent, 'Field class count: ', Cft^.ClassTable^.Count);
for n := 0 to Cft^.ClassTable^.Count - 1 do
begin
begin
WriteLn(Indent, ' ', n, ': ', Cft^.ClassTable^.Entries[n].ClassName);
end;
end;
AClass := AClass.ClassParent;
end;
end;
begin
ClassDump(TMyTest);
ClassDump(TMyTest2);