*** empty log message ***

tests/test/dumpclass.pp

@@ -0,0 +1,171 @@
+program DumpClass;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils;
+  
+const
+  VMT_COUNT = 100;                  
+
+
+type
+  TMethodNameTableEntry = packed record
+      Name: PShortstring;
+      Addr: Pointer;
+    end;
+
+  TMethodNameTable = packed record
+    Count: DWord;
+    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
+    Count: Word;
+    Entries: array[Word] of TPersistentClass;
+  end;
+
+  PFieldTable = ^TFieldTable;
+  TFieldTable = packed record
+    FieldCount: Word;
+    ClassTable: PFieldClassTable;
+    { Fields: array[Word] of TFieldInfo;  Elements have variant size! }
+  end;
+  
+{$M+}
+  TMyTest = class(TObject) 
+  published
+    F1: TMyTest;
+    F2: TMyTest;
+    procedure P1; virtual;
+    procedure P2; virtual;
+  end;
+{$M-}
+
+  TMyTest2 = class(TMyTest)
+    F3: TMyTest;                        
+    F4: TMyTest;
+    procedure P2; override;
+    procedure P3; virtual;
+  end;
+
+  TMyPersistent = class(TPersistent)
+    procedure P1; virtual;
+    procedure P2; virtual;
+  end;
+  
+procedure TMyTest.P1; 
+begin
+end;
+
+procedure TMyTest.P2; 
+begin
+end;
+
+procedure TMyTest2.P2; 
+begin
+end;
+
+procedure TMyTest2.P3; 
+begin
+end;
+
+procedure TMyPersistent.P1; 
+begin
+end;
+
+procedure TMyPersistent.P2; 
+begin
+end;
+
+procedure ClassDump(AClass: TClass);
+var
+  Cvmt: PPointerArray;
+  Cmnt: PMethodNameTable;
+  Cft:  PFieldTable;
+  FieldOffset: LongWord;
+  fi:  PFieldInfo;
+  Indent: String;
+  n, idx: Integer;
+  SearchAddr: Pointer;
+begin 
+  WriteLn('---------------------------------------------');
+  WriteLn('Dump of ', AClass.ClassName);
+  WriteLn('---------------------------------------------');
+  Indent := '';
+  while AClass <> nil do
+  begin
+    WriteLn(Indent, 'Processing ', AClass.Classname);
+    Indent := Indent + ' ';
+    
+    //---
+    Cmnt := PPointer(Pointer(AClass) + vmtMethodTable)^;
+    if Cmnt <> nil
+    then begin
+      WriteLn(Indent, 'Method count: ', IntToStr(Cmnt^.Count));
+
+      Cvmt := Pointer(AClass) + vmtMethodStart;
+          
+      for n := 0 to Cmnt^.Count - 1 do
+      begin                
+        Write(Indent, 'Search: ', Cmnt^.Entries[n].Name^);
+         
+        SearchAddr := Cmnt^.Entries[n].Addr;
+        for idx := 0 to VMT_COUNT - 1 do
+        begin
+          if Cvmt^[idx] = SearchAddr
+          then begin
+            WriteLn(Indent, ' Found at index: ', IntToStr(idx));
+            Break;
+          end;
+          if idx = VMT_COUNT - 1
+          then begin
+            WriteLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^, '" not found in "', AClass.ClassName, '"');
+            Break;
+          end;
+        end;                           
+      end;
+    end;
+    
+    
+    //---
+    Cft := PPointer(Pointer(AClass) + vmtFieldTable)^;
+    if Cft <> nil
+    then begin
+      WriteLn(Indent, 'Field count: ', Cft^.FieldCount);
+      fi := @Cft^.ClassTable + SizeOf(Cft^.ClassTable);
+      for n := 0 to Cft^.FieldCount - 1 do
+      begin 
+        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 
+        WriteLn(Indent, ' ', n, ': ', Cft^.ClassTable^.Entries[n].ClassName);
+      end;
+    end;
+    
+    AClass := AClass.ClassParent;
+  end;
+end;
+  
+begin
+  ClassDump(TMyTest);
+  ClassDump(TMyTest2);
+  ClassDump(TPersistent);
+  ClassDump(TMyPersistent);
+end.

tests/test/units/system/tint.pp

@@ -171,6 +171,10 @@ Begin
  r:=INT_VALUE_ONE;
  if Int(r)<>INT_RESULT_ONE then
    _success:=false;
+
+ if not _success then
+   fail;
+   
  if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then
    _success:=false;
  r:=INT_VALUE_ONE;
@@ -184,6 +188,8 @@ Begin
  if r<>INT_RESULT_ONE then
    _success:=false;
 
+ if not _success then
+   fail;
 
  r:=INT_VALUE_TWO;
  if Int(r)<>INT_RESULT_TWO then
@@ -221,7 +227,10 @@ end.
 
 {
   $Log$
-  Revision 1.3  2002-10-15 10:26:36  pierre
+  Revision 1.4  2004-12-27 12:10:08  florian
+  *** empty log message ***
+
+  Revision 1.3  2002/10/15 10:26:36  pierre
    * add code to remember that currency is only implemented in 1.1 compiler
 
   Revision 1.2  2002/09/18 18:30:30  carl