paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 12:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* extended test for bug

Browse Source 
git-svn-id: trunk@12728 -
This commit is contained in:
ivost 2009-02-09 00:33:08 +00:00
parent 54f3d28ce8
commit b3d611ab8f
1 changed files with 32 additions and 11 deletions

43
tests/webtbs/tw5800.pp
View File

@ -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;
if (gx<>2) or (gy<>2) or (gz<>2) then
begin
run;
writeln(gc,gx,gy,gz);
if (gc<>0) or (gx<>2) or (gy<>2) or (gz<>2) then
halt(1);
end.