* extended test for bug #5800

git-svn-id: trunk@12728 -

tests/webtbs/tw5800.pp

@@ -1,9 +1,17 @@
 {$IFDEF FPC}{$mode objfpc}{$ENDIF}
+{$h+}
 
 uses
   sysutils;
 
 type
+{$INTERFACES COM}
+
+  IAny3 = interface
+    ['{239041BD-BEC9-468A-93AA-96B158EF97E0}']
+    procedure z;
+  end;
+
 {$INTERFACES CORBA}
   IAny1 = interface
     ['{949041BD-BEC9-468A-93AA-96B158EF97E0}']
@@ -15,22 +23,28 @@ type
     procedure y;
   end;
 
-{$INTERFACES COM}
-
-  IAny3 = interface
-    ['{239041BD-BEC9-468A-93AA-96B158EF97E0}']
-    procedure z;
-  end;
-
   TAny = class(TInterfacedObject, IAny1, IAny2, IAny3)
     procedure x;
     procedure y;
     procedure z;
+    constructor create;
+    destructor destroy; override;
   end;
 
-
 var
-  gx,gy,gz: Integer;
+  gc,gx,gy,gz: Integer;
+
+constructor TAny.create;
+begin
+  inherited create;
+  Inc(gc);
+end;
+
+destructor TAny.destroy;
+begin
+  Dec(gc);
+  inherited destroy;
+end;
 
 procedure TAny.x;
 begin
@@ -48,16 +62,18 @@ begin
 end;
 
 
+procedure run;
 var
   a : TAny;
   i1 : IAny1;
   i2 : IAny2;
   i3 : IAny3;
 begin
+  gc := 0;
   gx := 0;
   gy := 0;
   gz := 0;
-  a := TAny.Create();
+  a := TAny.create();
 
   if not supports(TAny,IAny1) then
     halt(1);
@@ -86,7 +102,12 @@ begin
   (a as IAny1).x;
   (a as IAny2).y;
   (a as IAny3).z;
+end;
+
+begin
+  run;
+  writeln(gc,gx,gy,gz);
 
-  if (gx<>2) or (gy<>2) or (gz<>2) then
+  if (gc<>0) or (gx<>2) or (gy<>2) or (gz<>2) then
     halt(1);
 end.