Browse Source

no message

florian 20 years ago
parent
commit
e9676f56b8
1 changed files with 41 additions and 29 deletions
  1. 41 29
      tests/test/dumpclass.pp

+ 41 - 29
tests/test/dumpclass.pp

@@ -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);