paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 04:29:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* extended test for bug #5800

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
tests/webtbs/tw5800.pp
View File

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