paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-10 06:05:57 +02:00
Code Issues Packages Projects Releases Wiki Activity

* also check the base types of interfaces

Browse Source 
git-svn-id: trunk@37706 -
This commit is contained in:
svenbarth 2017-12-08 23:01:25 +00:00
parent b1029a218a
commit c15bcc693d
1 changed files with 19 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -1287,14 +1287,27 @@ procedure TTestCase1.TestInterface;
var
context: TRttiContext;
t: TRttiType;
ti1, ti2: TRttiInterfaceType;
begin
context := TRttiContext.Create;
try
t := context.GetType(TypeInfo(IInterface));
Check(t is TRttiInterfaceType, 'Type is not an interface type');
Check(not Assigned(t.BaseType), 'Base type is assigned');
ti1 := TRttiInterfaceType(t);
Check(not Assigned(ti1.BaseType), 'Base type is assigned');
t := context.GetType(TypeInfo(ITestInterface));
Check(t is TRttiInterfaceType, 'Type is not an interface type');
Check(Assigned(t.BaseType), 'Base type is not assigned');
Check(t.BaseType = TRttiType(ti1), 'Base type does not match');
ti2 := TRttiInterfaceType(t);
Check(Assigned(ti2.BaseType), 'Base type is not assigned');
Check(ti2.BaseType = ti1, 'Base type does not match');
finally
context.Free;
end;
@ -1305,11 +1318,17 @@ procedure TTestCase1.TestInterfaceRaw;
var
context: TRttiContext;
t: TRttiType;
ti: TRttiInterfaceType;
begin
context := TRttiContext.Create;
try
t := context.GetType(TypeInfo(ICORBATest));
Check(t is TRttiInterfaceType, 'Type is not a raw interface type');
Check(not Assigned(t.BaseType), 'Base type is assigned');
ti := TRttiInterfaceType(t);
Check(not Assigned(ti.BaseType), 'Base type is assigned');
finally
context.Free;
end;